Theory Sorted_List_Operations
section ‹\isaheader{Operations on sorted Lists}›
theory Sorted_List_Operations
imports Main Automatic_Refinement.Misc
begin
fun inter_sorted :: "'a::{linorder} list ⇒ 'a list ⇒ 'a list" where
"inter_sorted [] l2 = []"
| "inter_sorted l1 [] = []"
| "inter_sorted (x1 # l1) (x2 # l2) =
(if (x1 < x2) then (inter_sorted l1 (x2 # l2)) else
(if (x1 = x2) then x1 # (inter_sorted l1 l2) else inter_sorted (x1 # l1) l2))"
lemma inter_sorted_correct :
assumes l1_OK: "distinct l1 ∧ sorted l1"
assumes l2_OK: "distinct l2 ∧ sorted l2"
shows "distinct (inter_sorted l1 l2) ∧ sorted (inter_sorted l1 l2) ∧
set (inter_sorted l1 l2) = set l1 ∩ set l2"
using assms
proof (induct l1 arbitrary: l2)
case Nil thus ?case by simp
next
case (Cons x1 l1 l2)
note x1_l1_props = Cons(2)
note l2_props = Cons(3)
from x1_l1_props have l1_props: "distinct l1 ∧ sorted l1"
and x1_nin_l1: "x1 ∉ set l1"
and x1_le: "⋀x. x ∈ set l1 ⟹ x1 ≤ x"
by (simp_all add: Ball_def)
note ind_hyp_l1 = Cons(1)[OF l1_props]
show ?case
using l2_props
proof (induct l2)
case Nil with x1_l1_props show ?case by simp
next
case (Cons x2 l2)
note x2_l2_props = Cons(2)
from x2_l2_props have l2_props: "distinct l2 ∧ sorted l2"
and x2_nin_l2: "x2 ∉ set l2"
and x2_le: "⋀x. x ∈ set l2 ⟹ x2 ≤ x"
by (simp_all add: Ball_def)
note ind_hyp_l2 = Cons(1)[OF l2_props]
show ?case
proof (cases "x1 < x2")
case True note x1_less_x2 = this
from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
show ?thesis
apply (auto simp add: Ball_def)
apply (metis linorder_not_le)
done
next
case False note x2_le_x1 = this
show ?thesis
proof (cases "x1 = x2")
case True note x1_eq_x2 = this
from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
show ?thesis by (simp add: x1_eq_x2 Ball_def)
next
case False note x1_neq_x2 = this
with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto
from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
show ?thesis
apply (auto simp add: x2_less_x1 Ball_def)
apply (metis linorder_not_le x2_less_x1)
done
qed
qed
qed
qed
fun diff_sorted :: "'a::{linorder} list ⇒ 'a list ⇒ 'a list" where
"diff_sorted [] l2 = []"
| "diff_sorted l1 [] = l1"
| "diff_sorted (x1 # l1) (x2 # l2) =
(if (x1 < x2) then x1 # (diff_sorted l1 (x2 # l2)) else
(if (x1 = x2) then (diff_sorted l1 l2) else diff_sorted (x1 # l1) l2))"
lemma diff_sorted_correct :
assumes l1_OK: "distinct l1 ∧ sorted l1"
assumes l2_OK: "distinct l2 ∧ sorted l2"
shows "distinct (diff_sorted l1 l2) ∧ sorted (diff_sorted l1 l2) ∧
set (diff_sorted l1 l2) = set l1 - set l2"
using assms
proof (induct l1 arbitrary: l2)
case Nil thus ?case by simp
next
case (Cons x1 l1 l2)
note x1_l1_props = Cons(2)
note l2_props = Cons(3)
from x1_l1_props have l1_props: "distinct l1 ∧ sorted l1"
and x1_nin_l1: "x1 ∉ set l1"
and x1_le: "⋀x. x ∈ set l1 ⟹ x1 ≤ x"
by (simp_all add: Ball_def)
note ind_hyp_l1 = Cons(1)[OF l1_props]
show ?case
using l2_props
proof (induct l2)
case Nil with x1_l1_props show ?case by simp
next
case (Cons x2 l2)
note x2_l2_props = Cons(2)
from x2_l2_props have l2_props: "distinct l2 ∧ sorted l2"
and x2_nin_l2: "x2 ∉ set l2"
and x2_le: "⋀x. x ∈ set l2 ⟹ x2 ≤ x"
by (simp_all add: Ball_def)
note ind_hyp_l2 = Cons(1)[OF l2_props]
show ?case
proof (cases "x1 < x2")
case True note x1_less_x2 = this
from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
show ?thesis
apply simp
apply (simp add: Ball_def set_eq_iff)
apply (metis linorder_not_le order_less_imp_not_eq2)
done
next
case False note x2_le_x1 = this
show ?thesis
proof (cases "x1 = x2")
case True note x1_eq_x2 = this
from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
show ?thesis by (simp add: x1_eq_x2 Ball_def)
next
case False note x1_neq_x2 = this
with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto
from x2_less_x1 x1_le have x2_nin_l1: "x2 ∉ set l1"
by (metis linorder_not_less)
from ind_hyp_l2 x1_le x2_nin_l1
show ?thesis
apply (simp add: x2_less_x1 x1_neq_x2 x2_le_x1 x1_nin_l1 Ball_def set_eq_iff)
apply (metis x1_neq_x2)
done
qed
qed
qed
qed
fun subset_sorted :: "'a::{linorder} list ⇒ 'a list ⇒ bool" where
"subset_sorted [] l2 = True"
| "subset_sorted (x1 # l1) [] = False"
| "subset_sorted (x1 # l1) (x2 # l2) =
(if (x1 < x2) then False else
(if (x1 = x2) then (subset_sorted l1 l2) else subset_sorted (x1 # l1) l2))"
lemma subset_sorted_correct :
assumes l1_OK: "distinct l1 ∧ sorted l1"
assumes l2_OK: "distinct l2 ∧ sorted l2"
shows "subset_sorted l1 l2 ⟷ set l1 ⊆ set l2"
using assms
proof (induct l1 arbitrary: l2)
case Nil thus ?case by simp
next
case (Cons x1 l1 l2)
note x1_l1_props = Cons(2)
note l2_props = Cons(3)
from x1_l1_props have l1_props: "distinct l1 ∧ sorted l1"
and x1_nin_l1: "x1 ∉ set l1"
and x1_le: "⋀x. x ∈ set l1 ⟹ x1 ≤ x"
by (simp_all add: Ball_def)
note ind_hyp_l1 = Cons(1)[OF l1_props]
show ?case
using l2_props
proof (induct l2)
case Nil with x1_l1_props show ?case by simp
next
case (Cons x2 l2)
note x2_l2_props = Cons(2)
from x2_l2_props have l2_props: "distinct l2 ∧ sorted l2"
and x2_nin_l2: "x2 ∉ set l2"
and x2_le: "⋀x. x ∈ set l2 ⟹ x2 ≤ x"
by (simp_all add: Ball_def)
note ind_hyp_l2 = Cons(1)[OF l2_props]
show ?case
proof (cases "x1 < x2")
case True note x1_less_x2 = this
from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
show ?thesis
apply (auto simp add: Ball_def)
apply (metis linorder_not_le)
done
next
case False note x2_le_x1 = this
show ?thesis
proof (cases "x1 = x2")
case True note x1_eq_x2 = this
from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
show ?thesis
apply (simp add: subset_iff x1_eq_x2 Ball_def)
apply metis
done
next
case False note x1_neq_x2 = this
with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto
from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
show ?thesis
apply (simp add: subset_iff x2_less_x1 Ball_def)
apply (metis linorder_not_le x2_less_x1)
done
qed
qed
qed
qed
lemma set_eq_sorted_correct :
assumes l1_OK: "distinct l1 ∧ sorted l1"
assumes l2_OK: "distinct l2 ∧ sorted l2"
shows "l1 = l2 ⟷ set l1 = set l2"
using assms
proof -
have l12_eq: "l1 = l2 ⟷ subset_sorted l1 l2 ∧ subset_sorted l2 l1"
proof (induct l1 arbitrary: l2)
case Nil thus ?case by (cases l2) auto
next
case (Cons x1 l1')
note ind_hyp = Cons(1)
show ?case
proof (cases l2)
case Nil thus ?thesis by simp
next
case (Cons x2 l2')
thus ?thesis by (simp add: ind_hyp)
qed
qed
also have "… ⟷ ((set l1 ⊆ set l2) ∧ (set l2 ⊆ set l1))"
using subset_sorted_correct[OF l1_OK l2_OK] subset_sorted_correct[OF l2_OK l1_OK]
by simp
also have "… ⟷ set l1 = set l2" by auto
finally show ?thesis .
qed
fun memb_sorted where
"memb_sorted [] x = False"
| "memb_sorted (y # xs) x =
(if (y < x) then memb_sorted xs x else (x = y))"
lemma memb_sorted_correct :
"sorted xs ⟹ memb_sorted xs x ⟷ x ∈ set xs"
by (induct xs) (auto simp add: Ball_def)
fun insertion_sort where
"insertion_sort x [] = [x]"
| "insertion_sort x (y # xs) =
(if (y < x) then y # insertion_sort x xs else
(if (x = y) then y # xs else x # y # xs))"
lemma insertion_sort_correct :
"sorted xs ⟹ distinct xs ⟹
distinct (insertion_sort x xs) ∧
sorted (insertion_sort x xs) ∧
set (insertion_sort x xs) = set (x # xs)"
by (induct xs) (auto simp add: Ball_def)
fun delete_sorted where
"delete_sorted x [] = []"
| "delete_sorted x (y # xs) =
(if (y < x) then y # delete_sorted x xs else
(if (x = y) then xs else y # xs))"
lemma delete_sorted_correct :
"sorted xs ⟹ distinct xs ⟹
distinct (delete_sorted x xs) ∧
sorted (delete_sorted x xs) ∧
set (delete_sorted x xs) = set xs - {x}"
apply (induct xs)
apply simp
apply (simp add: Ball_def set_eq_iff)
apply (metis order_less_le)
done
end
Theory HashCode
section ‹\isaheader {The hashable Typeclass}›
theory HashCode
imports
Native_Word.Uint32
begin
text_raw ‹\label{thy:HashCode}›
text ‹
In this theory a typeclass of hashable types is established.
For hashable types, there is a function ‹hashcode›, that
maps any entity of this type to an unsigned 32 bit word value.
This theory defines the hashable typeclass and provides instantiations
for a couple of standard types.
›
type_synonym
hashcode = "uint32"
definition "nat_of_hashcode ≡ nat_of_uint32"
definition "int_of_hashcode ≡ int_of_uint32"
definition "integer_of_hashcode ≡ integer_of_uint32"
class hashable =
fixes hashcode :: "'a ⇒ hashcode"
and def_hashmap_size :: "'a itself ⇒ nat"
assumes def_hashmap_size: "1 < def_hashmap_size TYPE('a)"
begin
definition bounded_hashcode :: "uint32 ⇒ 'a ⇒ uint32" where
"bounded_hashcode n x = (hashcode x) mod n"
lemma bounded_hashcode_bounds: "1 < n ⟹ bounded_hashcode n a < n"
unfolding bounded_hashcode_def
by (transfer, simp add: word_less_def uint_mod)
definition bounded_hashcode_nat :: "nat ⇒ 'a ⇒ nat" where
"bounded_hashcode_nat n x = nat_of_hashcode (hashcode x) mod n"
lemma bounded_hashcode_nat_bounds: "1 < n ⟹ bounded_hashcode_nat n a < n"
unfolding bounded_hashcode_nat_def
by transfer simp
end
instantiation unit :: hashable
begin
definition [simp]: "hashcode (u :: unit) = 0"
definition "def_hashmap_size = (λ_ :: unit itself. 2)"
instance
by (intro_classes)(simp_all add: def_hashmap_size_unit_def)
end
instantiation bool :: hashable
begin
definition [simp]: "hashcode (b :: bool) = (if b then 1 else 0)"
definition "def_hashmap_size = (λ_ :: bool itself. 2)"
instance by (intro_classes)(simp_all add: def_hashmap_size_bool_def)
end
instantiation "int" :: hashable
begin
definition [simp]: "hashcode (i :: int) = uint32_of_int i"
definition "def_hashmap_size = (λ_ :: int itself. 16)"
instance by(intro_classes)(simp_all add: def_hashmap_size_int_def)
end
instantiation "integer" :: hashable
begin
definition [simp]: "hashcode (i :: integer) = Uint32 i"
definition "def_hashmap_size = (λ_ :: integer itself. 16)"
instance by(intro_classes)(simp_all add: def_hashmap_size_integer_def)
end
instantiation "nat" :: hashable
begin
definition [simp]: "hashcode (n :: nat) = uint32_of_int (int n)"
definition "def_hashmap_size = (λ_ :: nat itself. 16)"
instance by(intro_classes)(simp_all add: def_hashmap_size_nat_def)
end
instantiation char :: hashable
begin
definition [simp]: "hashcode (c :: char) == uint32_of_int (of_char c)"
definition "def_hashmap_size = (λ_ :: char itself. 32)"
instance by(intro_classes)(simp_all add: def_hashmap_size_char_def)
end
instantiation prod :: (hashable, hashable) hashable
begin
definition "hashcode x == (hashcode (fst x) * 33 + hashcode (snd x))"
definition "def_hashmap_size = (λ_ :: ('a × 'b) itself. def_hashmap_size TYPE('a) + def_hashmap_size TYPE('b))"
instance using def_hashmap_size[where ?'a="'a"] def_hashmap_size[where ?'a="'b"]
by(intro_classes)(simp_all add: def_hashmap_size_prod_def)
end
instantiation sum :: (hashable, hashable) hashable
begin
definition "hashcode x == (case x of Inl a ⇒ 2 * hashcode a | Inr b ⇒ 2 * hashcode b + 1)"
definition "def_hashmap_size = (λ_ :: ('a + 'b) itself. def_hashmap_size TYPE('a) + def_hashmap_size TYPE('b))"
instance using def_hashmap_size[where ?'a="'a"] def_hashmap_size[where ?'a="'b"]
by(intro_classes)(simp_all add: bounded_hashcode_bounds def_hashmap_size_sum_def split: sum.split)
end
instantiation list :: (hashable) hashable
begin
definition "hashcode = foldl (λh x. h * 33 + hashcode x) 5381"
definition "def_hashmap_size = (λ_ :: 'a list itself. 2 * def_hashmap_size TYPE('a))"
instance
proof
from def_hashmap_size[where ?'a = "'a"]
show "1 < def_hashmap_size TYPE('a list)"
by(simp add: def_hashmap_size_list_def)
qed
end
instantiation option :: (hashable) hashable
begin
definition "hashcode opt = (case opt of None ⇒ 0 | Some a ⇒ hashcode a + 1)"
definition "def_hashmap_size = (λ_ :: 'a option itself. def_hashmap_size TYPE('a) + 1)"
instance using def_hashmap_size[where ?'a = "'a"]
by(intro_classes)(simp_all add: def_hashmap_size_option_def split: option.split)
end
lemma hashcode_option_simps [simp]:
"hashcode None = 0"
"hashcode (Some a) = 1 + hashcode a"
by(simp_all add: hashcode_option_def)
lemma bounded_hashcode_option_simps [simp]:
"bounded_hashcode n None = 0"
"bounded_hashcode n (Some a) = (hashcode a + 1) mod n"
by (simp_all add: bounded_hashcode_def ac_simps)
instantiation String.literal :: hashable
begin
definition hashcode_literal :: "String.literal ⇒ uint32"
where "hashcode_literal s = hashcode (String.explode s)"
definition def_hashmap_size_literal :: "String.literal itself ⇒ nat"
where "def_hashmap_size_literal _ = 10"
instance
by standard (simp_all only: def_hashmap_size_literal_def)
end
hide_type (open) word
end
Theory SetIterator
section ‹\isaheader{Iterators over Finite Sets}›
theory SetIterator
imports
Automatic_Refinement.Misc
Automatic_Refinement.Foldi
begin
text ‹When reasoning about finite sets, it is often handy to be able to iterate over the elements
of the set. If the finite set is represented by a list, the @{term fold} operation can be used.
For general finite sets, the order of elements is not fixed though. Therefore, nondeterministic
iterators are introduced in this theory.›
subsection ‹General Iterators›
type_synonym ('x,'σ) set_iterator = "('σ⇒bool) ⇒ ('x⇒'σ⇒'σ) ⇒ 'σ ⇒ 'σ"
locale set_iterator_genord =
fixes iti::"('x,'σ) set_iterator"
and S0::"'x set"
and R::"'x ⇒ 'x ⇒ bool"
assumes foldli_transform:
"∃l0. distinct l0 ∧ S0 = set l0 ∧ sorted_wrt R l0 ∧ iti = foldli l0"
begin
text ‹Let's prove some trivial lemmata to show that the formalisation agrees with
the view of iterators described above.›
lemma set_iterator_weaken_R :
"(⋀x y. ⟦x ∈ S0; y ∈ S0; R x y⟧ ⟹ R' x y) ⟹
set_iterator_genord iti S0 R'"
by (metis set_iterator_genord.intro foldli_transform sorted_wrt_mono_rel)
lemma finite_S0 :
shows "finite S0"
by (metis finite_set foldli_transform)
lemma iti_stop_rule_cond :
assumes not_c: "¬(c σ)"
shows "iti c f σ = σ"
proof -
from foldli_transform obtain l0 where l0_props:
"iti c = foldli l0 c" by blast
with foldli_not_cond [of c σ l0 f, OF not_c]
show ?thesis by simp
qed
lemma iti_stop_rule_emp :
assumes S0_emp: "S0 = {}"
shows "iti c f σ = σ"
proof -
from foldli_transform obtain l0 where l0_props:
"S0 = set l0" "iti c = foldli l0 c" by blast
with foldli.simps(1) [of c f σ] S0_emp
show ?thesis by simp
qed
text ‹Reducing everything to folding is cumbersome. Let's
define a few high-level inference rules.›
lemma iteratei_rule_P:
assumes
"I S0 σ0"
"⋀S σ x. ⟦ c σ; x ∈ S; I S σ; S ⊆ S0;
∀y∈S - {x}. R x y; ∀y∈S0 - S. R y x⟧
⟹ I (S - {x}) (f x σ)"
"⋀σ. I {} σ ⟹ P σ"
"⋀σ S. ⟦ S ⊆ S0; S ≠ {}; ¬ c σ; I S σ;
∀x∈S. ∀y∈S0-S. R y x ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
proof -
{ fix P I σ0 f
assume
I: "I S0 σ0" and
R: "⋀S σ x. ⟦c σ; x ∈ S; I S σ; S ⊆ S0; ∀y∈S-{x}. R x y⟧ ⟹ I (S - {x}) (f x σ)" and
C1: "I {} (iti c f σ0) ⟹ P" and
C2:"⋀S. ⟦S ⊆ S0; S ≠ {}; ¬ c (iti c f σ0); I S (iti c f σ0)⟧ ⟹ P"
from foldli_transform obtain l0 where l0_props:
"distinct l0" "S0 = set l0" "sorted_wrt R l0" "iti c = foldli l0 c" by auto
from I R
have "I {} (iti c f σ0) ∨
(∃S. S ⊆ S0 ∧ S ≠ {} ∧
¬ (c (iti c f σ0)) ∧
I S (iti c f σ0))"
unfolding l0_props using l0_props(1,3)
proof (induct l0 arbitrary: σ0)
case Nil thus ?case by simp
next
case (Cons x l0)
note ind_hyp = Cons(1)
note I_x_l0 = Cons(2)
note step = Cons(3)
from Cons(4) have dist_l0: "distinct l0" and x_nin_l0: "x ∉ set l0" by simp_all
from Cons(5) have R_l0: "∀y∈set l0. R x y" and
sort_l0: "sorted_wrt R l0" by simp_all
show ?case
proof (cases "c σ0")
case False
with I_x_l0 show ?thesis
apply (rule_tac disjI2)
apply (rule_tac exI[where x="set (x # l0)"])
apply (simp)
done
next
case True note c_σ0 = this
from step[of σ0 x "set (x # l0)"] I_x_l0 R_l0 c_σ0 x_nin_l0
have step': "I (set l0) (f x σ0)"
by (simp_all add: Ball_def)
from ind_hyp [OF step' step dist_l0 sort_l0]
have "I {} (foldli l0 c f (f x σ0)) ∨
(∃S. S ⊆ set l0 ∧ S ≠ {} ∧
¬ c (foldli l0 c f (f x σ0)) ∧ I S (foldli l0 c f (f x σ0)))"
by (fastforce)
thus ?thesis
by (simp add: c_σ0 subset_iff) metis
qed
qed
with C1 C2 have "P" by blast
} note aux = this
from assms
show ?thesis
apply (rule_tac aux [of "λS σ. I S σ ∧ (∀x∈S. ∀y∈S0-S. R y x)" σ0 f])
apply auto
done
qed
text ‹Instead of removing elements one by one from the invariant, adding them is sometimes more natural.›
lemma iteratei_rule_insert_P:
assumes pre :
"I {} σ0"
"⋀S σ x. ⟦ c σ; x ∈ S0 - S; I S σ; S ⊆ S0; ∀y∈(S0 - S) - {x}. R x y;
∀y∈S. R y x⟧
⟹ I (insert x S) (f x σ)"
"⋀σ. I S0 σ ⟹ P σ"
"⋀σ S. ⟦ S ⊆ S0; S ≠ S0;
¬ (c σ); I S σ; ∀x∈S0-S. ∀y∈S. R y x ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
proof -
let ?I' = "λS σ. I (S0 - S) σ"
have pre1:
"!!σ S. ⟦ S ⊆ S0; S ≠ {}; ¬ (c σ); ?I' S σ;
∀x∈S. ∀y∈S0-S. R y x⟧ ⟹ P σ"
proof -
fix S σ
assume AA:
"S ⊆ S0" "S ≠ {}"
"¬ (c σ)"
"?I' S σ" "∀x∈S. ∀y∈S0-S. R y x"
with pre(4) [of "S0 - S"]
show "P σ" by auto
qed
have pre2 :"⋀x S σ. ⟦c σ; x ∈ S; S ⊆ S0; ?I' S σ; ∀y∈S - {x}. R x y; ∀y∈S0-S. R y x ⟧ ⟹ ?I' (S - {x}) (f x σ)"
proof -
fix x S σ
assume AA : "c σ" "x ∈ S" "S ⊆ S0" "?I' S σ" "∀y∈S - {x}. R x y" "∀y∈S0 - S. R y x"
from AA(2) AA(3) have "S0 - (S - {x}) = insert x (S0 - S)" "S0 - (S0 - S) = S" by auto
moreover
note pre(2) [of σ x "S0 - S"] AA
ultimately show "?I' (S - {x}) (f x σ)"
by auto
qed
show "P (iti c f σ0)"
apply (rule iteratei_rule_P [of ?I' σ0 c f P])
apply (simp add: pre)
apply (rule pre2) apply simp_all
apply (simp add: pre(3))
apply (simp add: pre1)
done
qed
text ‹Show that iti without interruption is related to fold›
lemma iti_fold:
assumes lc_f: "comp_fun_commute f"
shows "iti (λ_. True) f σ0 = Finite_Set.fold f σ0 S0"
proof (rule iteratei_rule_insert_P [where I = "λX σ'. σ' = Finite_Set.fold f σ0 X"])
fix S σ x
assume "x ∈ S0 - S" "S ⊆ S0" and σ_eq: "σ = Finite_Set.fold f σ0 S"
from finite_S0 ‹S ⊆ S0› have fin_S: "finite S" by (metis finite_subset)
from ‹x ∈ S0 - S› have x_nin_S: "x ∉ S" by simp
note fold_eq = comp_fun_commute.fold_insert [OF lc_f fin_S x_nin_S]
show "f x σ = Finite_Set.fold f σ0 (insert x S)"
by (simp add: fold_eq σ_eq)
qed simp_all
end
subsection ‹Iterators over Maps›
type_synonym ('k,'v,'σ) map_iterator = "('k×'v,'σ) set_iterator"
text ‹Iterator over the key-value pairs of a finite map are called iterators over maps.›
abbreviation "map_iterator_genord it m R ≡ set_iterator_genord it (map_to_set m) R"
subsection ‹Unordered Iterators›
text ‹Often one does not care about the order in which the elements are processed.
Therefore, the selection function can be set to not impose any further restrictings.
This leads to considerably simpler theorems.›
definition "set_iterator it S0 ≡ set_iterator_genord it S0 (λ_ _. True)"
abbreviation "map_iterator it m ≡ set_iterator it (map_to_set m)"
lemma set_iterator_intro :
"set_iterator_genord it S0 R ⟹ set_iterator it S0"
unfolding set_iterator_def
apply (rule set_iterator_genord.set_iterator_weaken_R [where R = R])
apply simp_all
done
lemma set_iterator_no_cond_rule_P:
"⟦ set_iterator it S0;
I S0 σ0;
!!S σ x. ⟦ x ∈ S; I S σ; S ⊆ S0 ⟧ ⟹ I (S - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (it (λ_. True) f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "λ_ _. True" I σ0 "λ_. True" f P]
by simp
lemma set_iterator_no_cond_rule_insert_P:
"⟦ set_iterator it S0;
I {} σ0;
!!S σ x. ⟦ x ∈ S0 - S; I S σ; S ⊆ S0 ⟧ ⟹ I (insert x S) (f x σ);
!!σ. I S0 σ ⟹ P σ
⟧ ⟹ P (it (λ_. True) f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "λ_ _. True" I σ0 "λ_. True" f P]
by simp
lemma set_iterator_rule_P:
"⟦ set_iterator it S0;
I S0 σ0;
!!S σ x. ⟦ c σ; x ∈ S; I S σ; S ⊆ S0 ⟧ ⟹ I (S - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "λ_ _. True" I σ0 c f P]
by simp
lemma set_iterator_rule_insert_P:
"⟦ set_iterator it S0;
I {} σ0;
!!S σ x. ⟦ c σ; x ∈ S0 - S; I S σ; S ⊆ S0 ⟧ ⟹ I (insert x S) (f x σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "λ_ _. True" I σ0 c f P]
by simp
text‹The following rules is adapted for maps. Instead of a set of key-value pairs the invariant
now only sees the keys.›
lemma map_iterator_genord_rule_P:
assumes "map_iterator_genord it m R"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; m k = Some v; it ⊆ dom m; I it σ;
∀k' v'. k' ∈ it-{k} ∧ m k' = Some v' ⟶ R (k, v) (k', v');
∀k' v'. k' ∉ it ∧ m k' = Some v' ⟶ R (k', v') (k, v)⟧ ⟹
I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ {}; ¬ c σ; I it σ;
∀k v k' v'. k ∉ it ∧ m k = Some v ∧ k' ∈ it ∧ m k' = Some v' ⟶
R (k, v) (k', v') ⟧ ⟹ P σ"
shows "P (it c f σ0)"
proof (rule set_iterator_genord.iteratei_rule_P [of it "map_to_set m" R "λS σ. I (fst ` S) σ" σ0 c f P])
show "map_iterator_genord it m R" by fact
next
show "I (fst ` map_to_set m) σ0" using I0 by (simp add: map_to_set_dom[symmetric])
next
fix σ
assume "I (fst ` {}) σ"
with IF show "P σ" by simp
next
fix σ S
assume "S ⊆ map_to_set m" "S ≠ {}" "¬ c σ" "I (fst ` S) σ"
and R_prop: "∀x∈S. ∀y∈map_to_set m - S. R y x"
let ?S' = "fst ` S"
show "P σ"
proof (rule II [where it = ?S'])
from ‹S ⊆ map_to_set m›
show "?S' ⊆ dom m"
unfolding map_to_set_dom
by auto
next
from ‹S ≠ {}› show "?S' ≠ {}" by auto
next
show "¬ (c σ)" by fact
next
show "I (fst ` S) σ" by fact
next
show "∀k v k' v'.
k ∉ fst ` S ∧
m k = Some v ∧
k' ∈ fst ` S ∧ m k' = Some v' ⟶
R (k, v) (k', v')"
proof (intro allI impI, elim conjE )
fix k v k' v'
assume pre_k: "k ∉ fst ` S" "m k = Some v"
assume pre_k': "k' ∈ fst ` S" "m k' = Some v'"
from ‹S ⊆ map_to_set m› pre_k'
have kv'_in: "(k', v') ∈ S"
unfolding map_to_set_def by auto
from ‹S ⊆ map_to_set m› pre_k
have kv_in: "(k, v) ∈ map_to_set m - S"
unfolding map_to_set_def
by (auto simp add: image_iff)
from R_prop kv_in kv'_in
show "R (k, v) (k',v')" by simp
qed
qed
next
fix σ S kv
assume "S ⊆ map_to_set m" "kv ∈ S" "c σ" and I_S': "I (fst ` S) σ" and
R_S: "∀kv'∈S - {kv}. R kv kv'" and
R_not_S: "∀kv'∈map_to_set m - S. R kv' kv"
let ?S' = "fst ` S"
obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
have "I (fst ` S - {k}) (f (k, v) σ)"
proof (rule IP)
show "c σ" by fact
next
from ‹kv ∈ S› show "k ∈ ?S'" by (auto simp add: image_iff Bex_def)
next
from ‹kv ∈ S› ‹S ⊆ map_to_set m›
have "kv ∈ map_to_set m" by auto
thus m_k_eq: "m k = Some v" unfolding map_to_set_def by simp
next
from ‹S ⊆ map_to_set m›
show S'_subset: "?S' ⊆ dom m"
unfolding map_to_set_dom
by auto
next
show "I (fst ` S) σ" by fact
next
from ‹S ⊆ map_to_set m› ‹kv ∈ S›
have S_simp: "{(k', v'). k' ∈ (fst ` S) - {k} ∧ m k' = Some v'} = S - {kv}"
unfolding map_to_set_def subset_iff
apply (auto simp add: image_iff Bex_def)
apply (metis option.inject)
done
from R_S[unfolded S_simp[symmetric]] R_not_S
show "∀k' v'. k' ∈ fst ` S - {k} ∧ m k' = Some v' ⟶
R (k, v) (k', v') "
by simp
next
from ‹S ⊆ map_to_set m› R_not_S
show "∀k' v'. k' ∉ fst ` S ∧ m k' = Some v' ⟶ R (k', v') (k, v)"
apply (simp add: Ball_def map_to_set_def subset_iff image_iff)
apply metis
done
qed
moreover
from ‹S ⊆ map_to_set m› ‹kv ∈ S›
have "fst ` (S - {kv}) = fst ` S - {k}"
apply (simp add: set_eq_iff image_iff Bex_def map_to_set_def subset_iff)
apply (metis option.inject)
done
ultimately show "I (fst ` (S - {kv})) (f kv σ)" by simp
qed
lemma map_iterator_genord_rule_insert_P:
assumes "map_iterator_genord it m R"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ dom m - it; m k = Some v; it ⊆ dom m; I it σ;
∀k' v'. k' ∈ (dom m - it) - {k} ∧ m k' = Some v' ⟶ R (k, v) (k', v');
∀k' v'. k' ∈ it ∧ m k' = Some v' ⟶
R (k', v') (k, v)⟧ ⟹ I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ dom m; ¬ c σ; I it σ;
∀k v k' v'. k ∈ it ∧ m k = Some v ∧ k' ∉ it ∧ m k' = Some v' ⟶
R (k, v) (k', v') ⟧ ⟹ P σ"
shows "P (it c f σ0)"
proof (rule map_iterator_genord_rule_P [of it m R "λS σ. I (dom m - S) σ"])
show "map_iterator_genord it m R" by fact
next
show "I (dom m - dom m) σ0" using I0 by simp
next
fix σ
assume "I (dom m - {}) σ"
with IF show "P σ" by simp
next
fix σ it
assume assms: "it ⊆ dom m" "it ≠ {}" "¬ c σ" "I (dom m - it) σ"
"∀k v k' v'. k ∉ it ∧ m k = Some v ∧ k' ∈ it ∧ m k' = Some v' ⟶
R (k, v) (k', v')"
from assms have "dom m - it ≠ dom m" by auto
with II[of "dom m - it" σ] assms
show "P σ"
apply (simp add: subset_iff dom_def)
apply (metis option.simps(2))
done
next
fix k v it σ
assume assms: "c σ" "k ∈ it" "m k = Some v" "it ⊆ dom m" "I (dom m - it) σ"
"∀k' v'. k' ∈ it - {k} ∧ m k' = Some v' ⟶ R (k, v) (k', v')"
"∀k' v'. k' ∉ it ∧ m k' = Some v' ⟶ R (k', v') (k, v)"
hence "insert k (dom m - it) = (dom m - (it - {k}))" "dom m - (dom m - it) = it" by auto
with assms IP[of σ k "dom m - it" v]
show "I (dom m - (it - {k})) (f (k, v) σ)" by (simp_all add: subset_iff)
qed
lemma map_iterator_rule_P:
assumes "map_iterator it m"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; m k = Some v; it ⊆ dom m; I it σ ⟧ ⟹ I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (it c f σ0)"
using assms map_iterator_genord_rule_P[of it m "λ_ _. True" I σ0 c f P]
unfolding set_iterator_def
by simp
lemma map_iterator_rule_insert_P:
assumes "map_iterator it m"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ dom m - it; m k = Some v; it ⊆ dom m; I it σ ⟧ ⟹ I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ dom m; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (it c f σ0)"
using assms map_iterator_genord_rule_insert_P[of it m "λ_ _. True" I σ0 c f P]
unfolding set_iterator_def
by simp
lemma map_iterator_no_cond_rule_P:
assumes "map_iterator it m"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ k ∈ it; m k = Some v; it ⊆ dom m; I it σ ⟧ ⟹ I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
shows "P (it (λ_. True) f σ0)"
using assms map_iterator_genord_rule_P[of it m "λ_ _. True" I σ0 "λ_. True" f P]
unfolding set_iterator_def
by simp
lemma map_iterator_no_cond_rule_insert_P:
assumes "map_iterator it m"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ k ∈ dom m - it; m k = Some v; it ⊆ dom m; I it σ ⟧ ⟹ I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
shows "P (it (λ_. True) f σ0)"
using assms map_iterator_genord_rule_insert_P[of it m "λ_ _. True" I σ0 "λ_. True" f P]
unfolding set_iterator_def
by simp
subsection ‹Ordered Iterators›
text ‹Selecting according to a linear order is another case that is interesting.
Ordered iterators over maps, i.\,e.\ iterators over key-value pairs,
use an order on the keys.›
context linorder begin
definition "set_iterator_linord it S0
≡ set_iterator_genord it S0 (≤)"
definition "set_iterator_rev_linord it S0
≡ set_iterator_genord it S0 (≥)"
definition "set_iterator_map_linord it S0 ≡
set_iterator_genord it S0 (λ(k,_) (k',_). k≤k')"
definition "set_iterator_map_rev_linord it S0 ≡
set_iterator_genord it S0 (λ(k,_) (k',_). k≥k')"
abbreviation "map_iterator_linord it m ≡
set_iterator_map_linord it (map_to_set m)"
abbreviation "map_iterator_rev_linord it m ≡
set_iterator_map_rev_linord it (map_to_set m)"
lemma set_iterator_linord_rule_P:
"⟦ set_iterator_linord it S0;
I S0 σ0;
!!S σ x. ⟦ c σ; x ∈ S; I S σ; S ⊆ S0; ⋀x'. x' ∈ S0-S ⟹ x' ≤ x; ⋀x'. x' ∈ S ⟹ x ≤ x'⟧ ⟹ I (S - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ (⋀x x'. ⟦x ∈ S; x' ∈ S0-S⟧ ⟹ x' ≤ x) ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_linord_def
apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(≤)" I σ0 c f P])
apply (simp_all add: Ball_def)
apply (metis order_refl)
done
lemma set_iterator_linord_rule_insert_P:
"⟦ set_iterator_linord it S0;
I {} σ0;
!!S σ x. ⟦ c σ; x ∈ S0 - S; I S σ; S ⊆ S0; ⋀x'. x' ∈ S ⟹ x' ≤ x; ⋀x'. x' ∈ S0 - S ⟹ x ≤ x'⟧ ⟹ I (insert x S) (f x σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ (⋀x x'. ⟦x ∈ S0-S; x' ∈ S⟧ ⟹ x' ≤ x) ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_linord_def
apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(≤)" I σ0 c f P])
apply (simp_all add: Ball_def)
apply (metis order_refl)
done
lemma set_iterator_rev_linord_rule_P:
"⟦ set_iterator_rev_linord it S0;
I S0 σ0;
!!S σ x. ⟦ c σ; x ∈ S; I S σ; S ⊆ S0; ⋀x'. x' ∈ S0-S ⟹ x ≤ x'; ⋀x'. x' ∈ S ⟹ x' ≤ x⟧ ⟹ I (S - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ (⋀x x'. ⟦x ∈ S; x' ∈ S0-S⟧ ⟹ x ≤ x') ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_rev_linord_def
apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(≥)" I σ0 c f P])
apply (simp_all add: Ball_def)
apply (metis order_refl)
done
lemma set_iterator_rev_linord_rule_insert_P:
"⟦ set_iterator_rev_linord it S0;
I {} σ0;
!!S σ x. ⟦ c σ; x ∈ S0 - S; I S σ; S ⊆ S0; ⋀x'. x' ∈ S ⟹ x ≤ x'; ⋀x'. x' ∈ S0 - S ⟹ x' ≤ x⟧ ⟹ I (insert x S) (f x σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ (⋀x x'. ⟦x ∈ S0-S; x' ∈ S⟧ ⟹ x ≤ x') ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_rev_linord_def
apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(≥)" I σ0 c f P])
apply (simp_all add: Ball_def)
apply (metis order_refl)
done
lemma set_iterator_map_linord_rule_P:
"⟦ set_iterator_map_linord it S0;
I S0 σ0;
!!S σ k v. ⟦ c σ; (k, v) ∈ S; I S σ; S ⊆ S0; ⋀k' v'. (k', v') ∈ S0-S ⟹ k' ≤ k;
⋀k' v'. (k', v') ∈ S ⟹ k ≤ k'⟧ ⟹ I (S - {(k,v)}) (f (k,v) σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ (⋀k v k' v'. ⟦(k, v) ∈ S0-S; (k', v') ∈ S⟧ ⟹ k ≤ k') ⟹
¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_map_linord_def
apply (rule set_iterator_genord.iteratei_rule_P
[of it S0 "(λ(k,_) (k',_). k ≤ k')" I σ0 c f P])
apply simp_all
apply (auto simp add: Ball_def)
apply (metis order_refl)
apply metis
done
lemma set_iterator_map_linord_rule_insert_P:
"⟦ set_iterator_map_linord it S0;
I {} σ0;
!!S σ k v. ⟦ c σ; (k, v) ∈ S0 - S; I S σ; S ⊆ S0; ⋀k' v'. (k', v') ∈ S ⟹ k' ≤ k;
⋀k' v'. (k',v') ∈ S0 - S ⟹ k ≤ k'⟧ ⟹ I (insert (k,v) S) (f (k,v) σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ (⋀k v k' v'. ⟦(k, v) ∈ S; (k', v') ∈ S0-S⟧ ⟹ k ≤ k') ⟹
¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_map_linord_def
apply (rule set_iterator_genord.iteratei_rule_insert_P
[of it S0 "(λ(k,_) (k',_). k ≤ k')" I σ0 c f P])
apply simp_all
apply (auto simp add: Ball_def)
apply (metis order_refl)
apply metis
done
lemma set_iterator_map_rev_linord_rule_P:
"⟦ set_iterator_map_rev_linord it S0;
I S0 σ0;
!!S σ k v. ⟦ c σ; (k, v) ∈ S; I S σ; S ⊆ S0; ⋀k' v'. (k', v') ∈ S0-S ⟹ k ≤ k';
⋀k' v'. (k', v') ∈ S ⟹ k' ≤ k⟧ ⟹ I (S - {(k,v)}) (f (k,v) σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ (⋀k v k' v'. ⟦(k, v) ∈ S0-S; (k', v') ∈ S⟧ ⟹ k' ≤ k) ⟹
¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_map_rev_linord_def
apply (rule set_iterator_genord.iteratei_rule_P
[of it S0 "(λ(k,_) (k',_). k ≥ k')" I σ0 c f P])
apply simp_all
apply (auto simp add: Ball_def)
apply (metis order_refl)
apply metis
done
lemma set_iterator_map_rev_linord_rule_insert_P:
"⟦ set_iterator_map_rev_linord it S0;
I {} σ0;
!!S σ k v. ⟦ c σ; (k, v) ∈ S0 - S; I S σ; S ⊆ S0; ⋀k' v'. (k', v') ∈ S ⟹ k ≤ k';
⋀k' v'. (k',v') ∈ S0 - S ⟹ k' ≤ k⟧ ⟹ I (insert (k,v) S) (f (k,v) σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ (⋀k v k' v'. ⟦(k, v) ∈ S; (k', v') ∈ S0-S⟧ ⟹ k' ≤ k) ⟹
¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_map_rev_linord_def
apply (rule set_iterator_genord.iteratei_rule_insert_P
[of it S0 "(λ(k,_) (k',_). k ≥ k')" I σ0 c f P])
apply simp_all
apply (auto simp add: Ball_def)
apply (metis order_refl)
apply metis
done
lemma map_iterator_linord_rule_P:
assumes "map_iterator_linord it m"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; m k = Some v; it ⊆ dom m; I it σ;
⋀k'. k' ∈ it ⟹ k ≤ k';
⋀k'. k' ∈ (dom m)-it ⟹ k' ≤ k⟧ ⟹ I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ {}; ¬ c σ; I it σ;
⋀k k'. ⟦k ∈ (dom m)-it; k' ∈ it⟧ ⟹ k ≤ k'⟧ ⟹ P σ"
shows "P (it c f σ0)"
using assms
unfolding set_iterator_map_linord_def
by (rule map_iterator_genord_rule_P) auto
lemma map_iterator_linord_rule_insert_P:
assumes "map_iterator_linord it m"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ dom m - it; m k = Some v; it ⊆ dom m; I it σ;
⋀k'. k' ∈ (dom m - it) ⟹ k ≤ k';
⋀k'. k' ∈ it ⟹ k' ≤ k ⟧ ⟹ I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ dom m; ¬ c σ; I it σ;
⋀k k'. ⟦k ∈ it; k' ∈ (dom m)-it⟧ ⟹ k ≤ k'⟧ ⟹ P σ"
shows "P (it c f σ0)"
using assms
unfolding set_iterator_map_linord_def
by (rule map_iterator_genord_rule_insert_P) auto
lemma map_iterator_rev_linord_rule_P:
assumes "map_iterator_rev_linord it m"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; m k = Some v; it ⊆ dom m; I it σ;
⋀k'. k' ∈ it ⟹ k' ≤ k;
⋀k'. k' ∈ (dom m)-it ⟹ k ≤ k'⟧ ⟹ I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ {}; ¬ c σ; I it σ;
⋀k k'. ⟦k ∈ (dom m)-it; k' ∈ it⟧ ⟹ k' ≤ k⟧ ⟹ P σ"
shows "P (it c f σ0)"
using assms
unfolding set_iterator_map_rev_linord_def
by (rule map_iterator_genord_rule_P) auto
lemma map_iterator_rev_linord_rule_insert_P:
assumes "map_iterator_rev_linord it m"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ dom m - it; m k = Some v; it ⊆ dom m; I it σ;
⋀k'. k' ∈ (dom m - it) ⟹ k' ≤ k;
⋀k'. k' ∈ it ⟹ k ≤ k'⟧ ⟹ I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ dom m; ¬ c σ; I it σ;
⋀k k'. ⟦k ∈ it; k' ∈ (dom m)-it⟧ ⟹ k' ≤ k⟧ ⟹ P σ"
shows "P (it c f σ0)"
using assms
unfolding set_iterator_map_rev_linord_def
by (rule map_iterator_genord_rule_insert_P) auto
end
subsection ‹Conversions to foldli›
lemma set_iterator_genord_foldli_conv :
"set_iterator_genord iti S R ⟷
(∃l0. distinct l0 ∧ S = set l0 ∧ sorted_wrt R l0 ∧ iti = foldli l0)"
unfolding set_iterator_genord_def by simp
lemma set_iterator_genord_I [intro] :
"⟦distinct l0; S = set l0; sorted_wrt R l0; iti = foldli l0⟧ ⟹
set_iterator_genord iti S R" unfolding set_iterator_genord_foldli_conv
by blast
lemma set_iterator_foldli_conv :
"set_iterator iti S ⟷
(∃l0. distinct l0 ∧ S = set l0 ∧ iti = foldli l0)"
unfolding set_iterator_def set_iterator_genord_def by simp
lemma set_iterator_I [intro] :
"⟦distinct l0; S = set l0; iti = foldli l0⟧ ⟹
set_iterator iti S"
unfolding set_iterator_foldli_conv
by blast
context linorder begin
lemma set_iterator_linord_foldli_conv :
"set_iterator_linord iti S ⟷
(∃l0. distinct l0 ∧ S = set l0 ∧ sorted l0 ∧ iti = foldli l0)"
unfolding set_iterator_linord_def set_iterator_genord_def by (simp add: sorted_sorted_wrt)
lemma set_iterator_linord_I [intro] :
"⟦distinct l0; S = set l0; sorted l0; iti = foldli l0⟧ ⟹
set_iterator_linord iti S"
unfolding set_iterator_linord_foldli_conv
by blast
lemma set_iterator_rev_linord_foldli_conv :
"set_iterator_rev_linord iti S ⟷
(∃l0. distinct l0 ∧ S = set l0 ∧ sorted (rev l0) ∧ iti = foldli l0)"
unfolding set_iterator_rev_linord_def set_iterator_genord_def by simp
lemma set_iterator_rev_linord_I [intro] :
"⟦distinct l0; S = set l0; sorted (rev l0); iti = foldli l0⟧ ⟹
set_iterator_rev_linord iti S"
unfolding set_iterator_rev_linord_foldli_conv
by blast
end
lemma map_iterator_genord_foldli_conv :
"map_iterator_genord iti m R ⟷
(∃(l0::('k × 'v) list). distinct (map fst l0) ∧ m = map_of l0 ∧ sorted_wrt R l0 ∧ iti = foldli l0)"
proof -
{ fix l0 :: "('k × 'v) list"
assume dist: "distinct l0"
have "(map_to_set m = set l0) ⟷
(distinct (map fst l0) ∧
m = map_of l0)"
proof (cases "distinct (map fst l0)")
case True thus ?thesis by (metis map_of_map_to_set)
next
case False note not_dist_fst = this
with dist have "~(inj_on fst (set l0))" by (simp add: distinct_map)
hence "set l0 ≠ map_to_set m"
by (rule_tac notI) (simp add: map_to_set_def inj_on_def)
with not_dist_fst show ?thesis by simp
qed
}
thus ?thesis
unfolding set_iterator_genord_def distinct_map
by metis
qed
lemma map_iterator_genord_I [intro] :
"⟦distinct (map fst l0); m = map_of l0; sorted_wrt R l0; iti = foldli l0⟧ ⟹
map_iterator_genord iti m R"
unfolding map_iterator_genord_foldli_conv
by blast
lemma map_iterator_foldli_conv :
"map_iterator iti m ⟷
(∃l0. distinct (map fst l0) ∧ m = map_of l0 ∧ iti = foldli l0)"
unfolding set_iterator_def map_iterator_genord_foldli_conv
by simp
lemma map_iterator_I [intro] :
"⟦distinct (map fst l0); m = map_of l0; iti = foldli l0⟧ ⟹
map_iterator iti m"
unfolding map_iterator_foldli_conv
by blast
context linorder begin
lemma sorted_wrt_keys_map_fst:
"sorted_wrt (λ(k,_) (k',_). R k k') l = sorted_wrt R (map fst l)"
by (induct l) auto
lemma map_iterator_linord_foldli_conv :
"map_iterator_linord iti m ⟷
(∃l0. distinct (map fst l0) ∧ m = map_of l0 ∧ sorted (map fst l0) ∧ iti = foldli l0)"
unfolding set_iterator_map_linord_def map_iterator_genord_foldli_conv
by (simp add: sorted_wrt_keys_map_fst sorted_sorted_wrt)
lemma map_iterator_linord_I [intro] :
"⟦distinct (map fst l0); m = map_of l0; sorted (map fst l0); iti = foldli l0⟧ ⟹
map_iterator_linord iti m"
unfolding map_iterator_linord_foldli_conv
by blast
lemma map_iterator_rev_linord_foldli_conv :
"map_iterator_rev_linord iti m ⟷
(∃l0. distinct (map fst l0) ∧ m = map_of l0 ∧ sorted (rev (map fst l0)) ∧ iti = foldli l0)"
unfolding set_iterator_map_rev_linord_def map_iterator_genord_foldli_conv
by (simp add: sorted_wrt_keys_map_fst)
lemma map_iterator_rev_linord_I [intro] :
"⟦distinct (map fst l0); m = map_of l0; sorted (rev (map fst l0)); iti = foldli l0⟧ ⟹
map_iterator_rev_linord iti m"
unfolding map_iterator_rev_linord_foldli_conv
by blast
end
end
Theory SetIteratorOperations
section ‹Operations on Set Iterators›
theory SetIteratorOperations
imports Main SetIterator
begin
text‹Many operations on sets can be lifted to iterators over sets. This theory tries to introduce
the most useful such operations.›
subsection ‹Empty set›
text ‹Iterators over empty sets and singleton sets are very easy to define.›
definition set_iterator_emp :: "('a,'σ) set_iterator" where
"set_iterator_emp c f σ0 = σ0"
lemma set_iterator_emp_foldli_conv :
"set_iterator_emp = foldli []"
by (simp add: fun_eq_iff set_iterator_emp_def)
lemma set_iterator_genord_emp_correct :
"set_iterator_genord set_iterator_emp {} R"
apply (rule set_iterator_genord.intro)
apply (rule exI[where x="[]"])
apply (simp add: set_iterator_emp_foldli_conv)
done
lemma set_iterator_emp_correct :
"set_iterator set_iterator_emp {}"
using set_iterator_intro [OF set_iterator_genord_emp_correct] .
lemma (in linorder) set_iterator_linord_emp_correct :
"set_iterator_linord set_iterator_emp {}"
unfolding set_iterator_linord_def
by (fact set_iterator_genord_emp_correct)
lemma (in linorder) set_iterator_rev_linord_emp_correct :
"set_iterator_rev_linord set_iterator_emp {}"
unfolding set_iterator_rev_linord_def
by (fact set_iterator_genord_emp_correct)
lemma (in linorder) map_iterator_linord_emp_correct :
"map_iterator_linord set_iterator_emp Map.empty"
"set_iterator_map_linord set_iterator_emp {}"
unfolding set_iterator_map_linord_def
by (simp_all add: set_iterator_genord_emp_correct map_to_set_def)
lemma (in linorder) map_iterator_rev_linord_emp_correct :
"map_iterator_rev_linord set_iterator_emp Map.empty"
"set_iterator_map_rev_linord set_iterator_emp {}"
unfolding set_iterator_map_rev_linord_def
by (simp_all add: set_iterator_genord_emp_correct map_to_set_def)
subsection‹Singleton Sets›
definition set_iterator_sng :: "'a ⇒ ('a,'σ) set_iterator" where
"set_iterator_sng x c f σ0 = (if c σ0 then f x σ0 else σ0)"
lemma set_iterator_sng_foldli_conv :
"set_iterator_sng x = foldli [x]"
by (simp add: fun_eq_iff set_iterator_sng_def)
lemma set_iterator_genord_sng_correct :
"set_iterator_genord (set_iterator_sng (x::'a)) {x} R"
apply (rule set_iterator_genord.intro)
apply (rule exI[where x="[x]"])
apply (simp add: set_iterator_sng_foldli_conv)
done
lemma set_iterator_sng_correct :
"set_iterator (set_iterator_sng x) {x}"
unfolding set_iterator_def
by (rule set_iterator_genord_sng_correct)
lemma (in linorder) set_iterator_linord_sng_correct :
"set_iterator_linord (set_iterator_sng x) {x}"
unfolding set_iterator_linord_def
by (simp add: set_iterator_genord_sng_correct)
lemma (in linorder) set_iterator_rev_linord_sng_correct :
"set_iterator_rev_linord (set_iterator_sng x) {x}"
unfolding set_iterator_rev_linord_def
by (simp add: set_iterator_genord_sng_correct)
lemma (in linorder) map_iterator_linord_sng_correct :
"map_iterator_linord (set_iterator_sng (k,v)) (Map.empty (k ↦ v))"
unfolding set_iterator_map_linord_def
by (simp add: set_iterator_genord_sng_correct)
lemma (in linorder) map_iterator_rev_linord_sng_correct :
"map_iterator_rev_linord (set_iterator_sng (k,v)) (Map.empty (k ↦ v))"
unfolding set_iterator_map_rev_linord_def
by (simp add: set_iterator_genord_sng_correct)
subsection ‹Union›
text ‹Iterators over disjoint sets can be combined by first iterating over one and then the
other set. The result is an iterator over the union of the original sets.›
definition set_iterator_union ::
"('a,'σ) set_iterator ⇒ ('a, 'σ) set_iterator ⇒ ('a,'σ) set_iterator" where
"set_iterator_union it_a it_b ≡ λc f σ0. (it_b c f (it_a c f σ0))"
lemma set_iterator_union_foldli_conv :
"set_iterator_union (foldli as) (foldli bs) = foldli (as @ bs)"
by (simp add: fun_eq_iff set_iterator_union_def foldli_append)
lemma set_iterator_genord_union_correct :
fixes it_a :: "('a,'σ) set_iterator"
fixes it_b :: "('a,'σ) set_iterator"
fixes R S_a S_b
assumes it_a: "set_iterator_genord it_a S_a R"
assumes it_b: "set_iterator_genord it_b S_b R"
assumes dist_Sab: "S_a ∩ S_b = {}"
assumes R_OK: "⋀a b. ⟦a ∈ S_a; b ∈ S_b⟧ ⟹ R a b"
shows "set_iterator_genord (set_iterator_union it_a it_b) (S_a ∪ S_b) R"
proof -
from it_a obtain as where
dist_as: "distinct as" and S_a_eq: "S_a = set as" and
sorted_as: "sorted_wrt R as" and it_a_eq: "it_a = foldli as"
unfolding set_iterator_genord_foldli_conv by blast
from it_b obtain bs where
dist_bs: "distinct bs" and S_b_eq: "S_b = set bs" and
sorted_bs: "sorted_wrt R bs" and it_b_eq: "it_b = foldli bs"
unfolding set_iterator_genord_foldli_conv by blast
show ?thesis
proof (rule set_iterator_genord_I [of "as @ bs"])
from dist_Sab S_a_eq S_b_eq dist_as dist_bs
show "distinct (as @ bs)" by simp
next
from S_a_eq S_b_eq
show "S_a ∪ S_b = set (as @ bs)" by simp
next
from sorted_as sorted_bs R_OK S_a_eq S_b_eq
show "sorted_wrt R (as @ bs)"
by (simp add: sorted_wrt_append Ball_def)
next
show "set_iterator_union it_a it_b = (foldli (as @ bs))"
unfolding it_a_eq it_b_eq set_iterator_union_foldli_conv by simp
qed
qed
lemma set_iterator_union_emp [simp] :
"set_iterator_union (set_iterator_emp) it = it"
"set_iterator_union it (set_iterator_emp) = it"
unfolding set_iterator_emp_def set_iterator_union_def
by simp_all
lemma set_iterator_union_correct :
assumes it_a: "set_iterator it_a S_a"
assumes it_b: "set_iterator it_b S_b"
assumes dist_Sab: "S_a ∩ S_b = {}"
shows "set_iterator (set_iterator_union it_a it_b) (S_a ∪ S_b)"
proof -
note res' = set_iterator_genord_union_correct [OF it_a[unfolded set_iterator_def]
it_b[unfolded set_iterator_def] dist_Sab]
from set_iterator_intro [OF res']
show ?thesis by simp
qed
lemma (in linorder) set_iterator_linord_union_correct :
assumes it_a: "set_iterator_linord it_a S_a"
assumes it_b: "set_iterator_linord it_b S_b"
assumes ord_Sab: "⋀a b. ⟦a ∈ S_a; b ∈ S_b⟧ ⟹ a < b"
shows "set_iterator_linord (set_iterator_union it_a it_b) (S_a ∪ S_b)"
unfolding set_iterator_linord_def
apply (rule_tac set_iterator_genord_union_correct[
OF it_a[unfolded set_iterator_linord_def] it_b[unfolded set_iterator_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le ord_Sab)
done
lemma (in linorder) set_iterator_rev_linord_union_correct :
assumes it_a: "set_iterator_rev_linord it_a S_a"
assumes it_b: "set_iterator_rev_linord it_b S_b"
assumes ord_Sab: "⋀a b. ⟦a ∈ S_a; b ∈ S_b⟧ ⟹ a > b"
shows "set_iterator_rev_linord (set_iterator_union it_a it_b) (S_a ∪ S_b)"
unfolding set_iterator_rev_linord_def
apply (rule_tac set_iterator_genord_union_correct[
OF it_a[unfolded set_iterator_rev_linord_def] it_b[unfolded set_iterator_rev_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le ord_Sab)
done
lemma (in linorder) map_iterator_linord_union_correct :
assumes it_a: "set_iterator_map_linord it_a S_a"
assumes it_b: "set_iterator_map_linord it_b S_b"
assumes ord_Sab: "⋀kv kv'. ⟦kv ∈ S_a; kv' ∈ S_b⟧ ⟹ fst kv < fst kv'"
shows "set_iterator_map_linord (set_iterator_union it_a it_b) (S_a ∪ S_b)"
unfolding set_iterator_map_linord_def
apply (rule set_iterator_genord_union_correct [OF
it_a[unfolded set_iterator_map_linord_def]
it_b[unfolded set_iterator_map_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le)
done
lemma (in linorder) map_iterator_rev_linord_union_correct :
assumes it_a: "set_iterator_map_rev_linord it_a S_a"
assumes it_b: "set_iterator_map_rev_linord it_b S_b"
assumes ord_Sab: "⋀kv kv'. ⟦kv ∈ S_a; kv' ∈ S_b⟧ ⟹ fst kv > fst kv'"
shows "set_iterator_map_rev_linord (set_iterator_union it_a it_b) (S_a ∪ S_b)"
unfolding set_iterator_map_rev_linord_def
apply (rule set_iterator_genord_union_correct [OF
it_a[unfolded set_iterator_map_rev_linord_def]
it_b[unfolded set_iterator_map_rev_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le)
done
subsection ‹Product›
definition set_iterator_product ::
"('a,'σ) set_iterator ⇒ ('a ⇒ ('b,'σ) set_iterator) ⇒ ('a × 'b ,'σ) set_iterator" where
"set_iterator_product it_a it_b ≡ λc f σ0.
it_a c (
λa σ. it_b a c (λb σ. f (a,b) σ) σ
) σ0"
lemma set_iterator_product_foldli_conv:
"set_iterator_product (foldli as) (λa. foldli (bs a)) =
foldli (concat (map (λa. map (λb. (a, b)) (bs a)) as))"
apply (induct as)
apply (simp add: set_iterator_product_def)
apply (simp add: set_iterator_product_def foldli_append foldli_map o_def fun_eq_iff)
done
lemma set_iterator_product_it_b_cong:
assumes it_a_OK: "set_iterator it_a S_a"
and it_b_b': "⋀a. a ∈ S_a ⟹ it_b a = it_b' a"
shows "set_iterator_product it_a it_b =
set_iterator_product it_a it_b'"
proof -
from it_a_OK obtain as where
dist_as: "distinct as" and S_a_eq: "S_a = set as" and
it_a_eq: "it_a = foldli as"
unfolding set_iterator_foldli_conv by blast
from it_b_b'[unfolded S_a_eq]
show ?thesis unfolding it_a_eq
by (induct as)
(simp_all add: set_iterator_product_def it_b_b' fun_eq_iff)
qed
definition set_iterator_product_order ::
"('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'b ⇒ 'b ⇒ bool) ⇒
('a × 'b) ⇒ ('a × 'b) ⇒ bool" where
"set_iterator_product_order R_a R_b ab ab' ⟷
(if (fst ab = fst ab') then R_b (fst ab) (snd ab) (snd ab') else
R_a (fst ab) (fst ab'))"
lemma set_iterator_genord_product_correct :
fixes it_a :: "('a,'σ) set_iterator"
fixes it_b :: "'a ⇒ ('b,'σ) set_iterator"
assumes it_a: "set_iterator_genord it_a S_a R_a"
assumes it_b: "⋀a. a ∈ S_a ⟹ set_iterator_genord (it_b a) (S_b a) (R_b a)"
shows "set_iterator_genord (set_iterator_product it_a it_b) (Sigma S_a S_b)
(set_iterator_product_order R_a R_b)"
proof -
from it_a obtain as where
dist_as: "distinct as" and S_a_eq: "S_a = set as" and
sorted_as: "sorted_wrt R_a as" and it_a_eq: "it_a = foldli as"
unfolding set_iterator_genord_foldli_conv by blast
from it_b obtain bs where
dist_bs: "⋀a. a ∈ set as ⟹ distinct (bs a)" and S_b_eq: "⋀a. a ∈ set as ⟹ S_b a = set (bs a)" and
sorted_bs: "⋀a. a ∈ set as ⟹ sorted_wrt (R_b a) (bs a)" and
it_b_eq: "⋀a. a ∈ set as ⟹ it_b a = foldli (bs a)"
unfolding set_iterator_genord_foldli_conv by (metis S_a_eq)
let ?abs = "concat (map (λa. map (λb. (a, b)) (bs a)) as)"
show ?thesis
proof (rule set_iterator_genord_I[of ?abs])
from set_iterator_product_it_b_cong[of it_a S_a it_b,
OF set_iterator_intro[OF it_a] it_b_eq] it_a_eq S_a_eq
have "set_iterator_product it_a it_b =
set_iterator_product (foldli as) (λa. foldli (bs a))" by simp
thus "set_iterator_product it_a it_b = foldli ?abs"
by (simp add: set_iterator_product_foldli_conv)
next
show "distinct ?abs"
using dist_as dist_bs[unfolded S_a_eq]
by (induct as)
(simp_all add: distinct_map inj_on_def dist_bs set_eq_iff image_iff)
next
show "Sigma S_a S_b = set ?abs"
unfolding S_a_eq using S_b_eq
by (induct as) auto
next
from sorted_as sorted_bs dist_as
show "sorted_wrt
(set_iterator_product_order R_a R_b)
(concat (map (λa. map (Pair a) (bs a)) as))"
proof (induct as rule: list.induct)
case Nil thus ?case by simp
next
case (Cons a as)
from Cons(2) have R_a_as: "⋀a'. a' ∈ set as ⟹ R_a a a'" and
sorted_as: "sorted_wrt R_a as" by simp_all
from Cons(3) have sorted_bs_a: "sorted_wrt (R_b a) (bs a)"
and sorted_bs_as: "⋀a. a ∈ set as ⟹ sorted_wrt (R_b a) (bs a)" by simp_all
from Cons(4) have dist_as: "distinct as" and a_nin_as: "a ∉ set as" by simp_all
note ind_hyp = Cons(1)[OF sorted_as sorted_bs_as dist_as]
define bs_a where "bs_a = bs a"
from sorted_bs_a
have sorted_prod_a : "sorted_wrt (set_iterator_product_order R_a R_b) (map (Pair a) (bs a))"
unfolding bs_a_def[symmetric]
apply (induct bs_a rule: list.induct)
apply (simp_all add: set_iterator_product_order_def Ball_def image_iff)
done
show ?case
apply (simp add: sorted_wrt_append ind_hyp sorted_prod_a)
apply (simp add: set_iterator_product_order_def R_a_as a_nin_as)
done
qed
qed
qed
lemma set_iterator_product_correct :
assumes it_a: "set_iterator it_a S_a"
assumes it_b: "⋀a. a ∈ S_a ⟹ set_iterator (it_b a) (S_b a)"
shows "set_iterator (set_iterator_product it_a it_b) (Sigma S_a S_b)"
proof -
note res' = set_iterator_genord_product_correct [OF it_a[unfolded set_iterator_def],
of it_b S_b "λ_ _ _. True", OF it_b[unfolded set_iterator_def]]
note res = set_iterator_intro [OF res']
thus ?thesis by simp
qed
subsection ‹Filter and Image›
text ‹Filtering and applying an injective function on iterators is easily defineable as well.
In contrast to sets the function really has to be injective, because an iterator guarentees to
visit each element only once.›
definition set_iterator_image_filter ::
"('a ⇒ 'b option) ⇒ ('a,'σ) set_iterator ⇒ ('b,'σ) set_iterator" where
"set_iterator_image_filter g it ≡ λc f σ0. (it c
(λx σ. (case (g x) of Some x' ⇒ f x' σ | None ⇒ σ)) σ0)"
lemma set_iterator_image_filter_foldli_conv :
"set_iterator_image_filter g (foldli xs) =
foldli (List.map_filter g xs)"
by (induct xs) (auto simp add: List.map_filter_def set_iterator_image_filter_def fun_eq_iff)
lemma set_iterator_genord_image_filter_correct :
fixes it :: "('a,'σ) set_iterator"
fixes g :: "'a ⇒ 'b option"
assumes it_OK: "set_iterator_genord it S R"
assumes g_inj_on: "inj_on g (S ∩ dom g)"
assumes R'_prop: "⋀x y x' y'. ⟦x ∈ S; g x = Some x'; y ∈ S; g y = Some y'; R x y⟧ ⟹ R' x' y'"
shows "set_iterator_genord (set_iterator_image_filter g it) {y. ∃x. x ∈ S ∧ g x = Some y} R'"
proof -
from it_OK obtain xs where
dist_xs: "distinct xs" and S_eq: "S = set xs" and
sorted_xs: "sorted_wrt R xs" and it_eq: "it = foldli xs"
unfolding set_iterator_genord_foldli_conv by blast
show ?thesis
proof (rule set_iterator_genord_I [of "List.map_filter g xs"])
show "set_iterator_image_filter g it =
foldli (List.map_filter g xs)"
unfolding it_eq set_iterator_image_filter_foldli_conv by simp
next
from dist_xs g_inj_on[unfolded S_eq]
show "distinct (List.map_filter g xs)"
apply (induct xs)
apply (simp add: List.map_filter_simps)
apply (simp add: List.map_filter_def image_iff inj_on_def Ball_def dom_def)
apply (metis not_Some_eq option.sel)
done
next
show "{y. ∃x. x ∈ S ∧ g x = Some y} =
set (List.map_filter g xs)"
unfolding S_eq set_map_filter by simp
next
from sorted_xs R'_prop[unfolded S_eq]
show "sorted_wrt R' (List.map_filter g xs)"
proof (induct xs rule: list.induct)
case Nil thus ?case by (simp add: List.map_filter_simps)
next
case (Cons x xs)
note sort_x_xs = Cons(2)
note R'_x_xs = Cons(3)
from Cons have ind_hyp: "sorted_wrt R' (List.map_filter g xs)" by auto
show ?case
apply (cases "g x")
apply (simp add: List.map_filter_simps ind_hyp)
apply (simp add: List.map_filter_simps set_map_filter Ball_def ind_hyp)
apply (insert R'_x_xs[of x] sort_x_xs)
apply (simp add: Ball_def)
apply metis
done
qed
qed
qed
lemma set_iterator_image_filter_correct :
fixes it :: "('a,'σ) set_iterator"
fixes g :: "'a ⇒ 'b option"
assumes it_OK: "set_iterator it S"
assumes g_inj_on: "inj_on g (S ∩ dom g)"
shows "set_iterator (set_iterator_image_filter g it) {y. ∃x. x ∈ S ∧ g x = Some y}"
proof -
note res' = set_iterator_genord_image_filter_correct [OF it_OK[unfolded set_iterator_def],
of g "λ_ _. True"]
note res = set_iterator_intro [OF res']
with g_inj_on show ?thesis by simp
qed
text ‹Special definitions for only filtering or only appling a function are handy.›
definition set_iterator_filter ::
"('a ⇒ bool) ⇒ ('a,'σ) set_iterator ⇒ ('a,'σ) set_iterator" where
"set_iterator_filter P ≡ set_iterator_image_filter (λx. if P x then Some x else None)"
lemma set_iterator_filter_foldli_conv :
"set_iterator_filter P (foldli xs) = foldli (filter P xs)"
apply (simp add: set_iterator_filter_def set_iterator_image_filter_foldli_conv)
apply (rule cong) apply simp
apply (induct xs)
apply (simp_all add: List.map_filter_def)
done
lemma set_iterator_filter_alt_def [code] :
"set_iterator_filter P it = (λc f. it c (λ(x::'a) (σ::'b). if P x then f x σ else σ))"
proof -
have "⋀f. (λ(x::'a) (σ::'b).
case if P x then Some x else None of None ⇒ σ
| Some x' ⇒ f x' σ) =
(λx σ. if P x then f x σ else σ)"
by auto
thus ?thesis
unfolding set_iterator_filter_def
set_iterator_image_filter_def[abs_def]
by simp
qed
lemma set_iterator_genord_filter_correct :
fixes it :: "('a,'σ) set_iterator"
assumes it_OK: "set_iterator_genord it S R"
shows "set_iterator_genord (set_iterator_filter P it) {x. x ∈ S ∧ P x} R"
proof -
let ?g = "λx. if P x then Some x else None"
have in_dom_g: "⋀x. x ∈ dom ?g ⟷ P x" unfolding dom_def by auto
from set_iterator_genord_image_filter_correct [OF it_OK, of ?g R, folded set_iterator_filter_def]
show ?thesis
by (simp add: if_split_eq1 inj_on_def Ball_def in_dom_g)
qed
lemma set_iterator_filter_correct :
assumes it_OK: "set_iterator it S"
shows "set_iterator (set_iterator_filter P it) {x. x ∈ S ∧ P x}"
proof -
note res' = set_iterator_genord_filter_correct [OF it_OK[unfolded set_iterator_def],
of P]
note res = set_iterator_intro [OF res']
thus ?thesis by simp
qed
lemma (in linorder) set_iterator_linord_filter_correct :
assumes it_OK: "set_iterator_linord it S"
shows "set_iterator_linord (set_iterator_filter P it) {x. x ∈ S ∧ P x}"
using assms
unfolding set_iterator_linord_def
by (rule set_iterator_genord_filter_correct)
lemma (in linorder) set_iterator_rev_linord_filter_correct :
assumes it_OK: "set_iterator_rev_linord it S"
shows "set_iterator_rev_linord (set_iterator_filter P it) {x. x ∈ S ∧ P x}"
using assms
unfolding set_iterator_rev_linord_def
by (rule set_iterator_genord_filter_correct)
definition set_iterator_image ::
"('a ⇒ 'b) ⇒ ('a,'σ) set_iterator ⇒ ('b,'σ) set_iterator" where
"set_iterator_image g ≡ set_iterator_image_filter (λx. Some (g x))"
lemma set_iterator_image_foldli_conv :
"set_iterator_image g (foldli xs) = foldli (map g xs)"
apply (simp add: set_iterator_image_def set_iterator_image_filter_foldli_conv)
apply (rule cong) apply simp
apply (induct xs)
apply (simp_all add: List.map_filter_def)
done
lemma set_iterator_image_alt_def [code] :
"set_iterator_image g it = (λc f. it c (λx. f (g x)))"
unfolding set_iterator_image_def
set_iterator_image_filter_def[abs_def]
by simp
lemma set_iterator_genord_image_correct :
fixes it :: "('a,'σ) set_iterator"
assumes it_OK: "set_iterator_genord it S R"
assumes g_inj: "inj_on g S"
assumes R'_prop: "⋀x y. ⟦x ∈ S; y ∈ S; R x y⟧ ⟹ R' (g x) (g y)"
shows "set_iterator_genord (set_iterator_image g it) (g ` S) R'"
proof -
let ?g = "λx. Some (g x)"
have set_eq: "⋀S. {y . ∃x. x ∈ S ∧ ?g x = Some y} = g ` S" by auto
show ?thesis
apply (rule set_iterator_genord_image_filter_correct [OF it_OK, of ?g R',
folded set_iterator_image_def set_eq[symmetric]])
apply (insert g_inj, simp add: inj_on_def) []
apply (insert R'_prop, auto)
done
qed
lemma set_iterator_image_correct :
assumes it_OK: "set_iterator it S"
assumes g_inj: "inj_on g S"
assumes S'_OK: "S' = g ` S"
shows "set_iterator (set_iterator_image g it) S'"
proof -
note res' = set_iterator_genord_image_correct [OF it_OK[unfolded set_iterator_def] g_inj,
of "λ_ _. True"]
note res = set_iterator_intro [OF res', folded S'_OK]
thus ?thesis by simp
qed
subsection ‹Construction from list (foldli)›
text ‹Iterators correspond by definition to iteration over distinct lists. They fix an order
in which the elements are visited. Therefore, it is trivial to construct an iterator from a
distinct list.›
lemma set_iterator_genord_foldli_correct :
"distinct xs ⟹ sorted_wrt R xs ⟹ set_iterator_genord (foldli xs) (set xs) R"
by (rule set_iterator_genord_I[of xs]) (simp_all)
lemma set_iterator_foldli_correct :
"distinct xs ⟹ set_iterator (foldli xs) (set xs)"
by (rule set_iterator_I[of xs]) (simp_all)
lemma (in linorder) set_iterator_linord_foldli_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted xs"
shows "set_iterator_linord (foldli xs) (set xs)"
using assms
by (rule_tac set_iterator_linord_I[of xs]) (simp_all)
lemma (in linorder) set_iterator_rev_linord_foldli_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted (rev xs)"
shows "set_iterator_rev_linord (foldli xs) (set xs)"
using assms
by (rule_tac set_iterator_rev_linord_I[of xs]) (simp_all)
lemma map_iterator_genord_foldli_correct :
"distinct (map fst xs) ⟹ sorted_wrt R xs ⟹ map_iterator_genord (foldli xs) (map_of xs) R"
by (rule map_iterator_genord_I[of xs]) simp_all
lemma map_iterator_foldli_correct :
"distinct (map fst xs) ⟹ map_iterator (foldli xs) (map_of xs)"
by (rule map_iterator_I[of xs]) (simp_all)
lemma (in linorder) map_iterator_linord_foldli_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (map fst xs)"
shows "map_iterator_linord (foldli xs) (map_of xs)"
using assms
by (rule_tac map_iterator_linord_I[of xs]) (simp_all)
lemma (in linorder) map_iterator_rev_linord_foldli_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (rev (map fst xs))"
shows "map_iterator_rev_linord (foldli xs) (map_of xs)"
using assms
by (rule_tac map_iterator_rev_linord_I[of xs]) (simp_all)
subsection ‹Construction from list (foldri)›
lemma set_iterator_genord_foldri_correct :
"distinct xs ⟹ sorted_wrt R (rev xs) ⟹ set_iterator_genord (foldri xs) (set xs) R"
by (rule set_iterator_genord_I[of "rev xs"]) (simp_all add: foldri_def)
lemma set_iterator_foldri_correct :
"distinct xs ⟹ set_iterator (foldri xs) (set xs)"
by (rule set_iterator_I[of "rev xs"]) (simp_all add: foldri_def)
lemma (in linorder) set_iterator_linord_foldri_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted (rev xs)"
shows "set_iterator_linord (foldri xs) (set xs)"
using assms
by (rule_tac set_iterator_linord_I[of "rev xs"]) (simp_all add: foldri_def)
lemma (in linorder) set_iterator_rev_linord_foldri_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted xs"
shows "set_iterator_rev_linord (foldri xs) (set xs)"
using assms
by (rule_tac set_iterator_rev_linord_I[of "rev xs"]) (simp_all add: foldri_def)
lemma map_iterator_genord_foldri_correct :
"distinct (map fst xs) ⟹ sorted_wrt R (rev xs) ⟹ map_iterator_genord (foldri xs) (map_of xs) R"
by (rule map_iterator_genord_I[of "rev xs"])
(simp_all add: rev_map[symmetric] foldri_def)
lemma map_iterator_foldri_correct :
"distinct (map fst xs) ⟹ map_iterator (foldri xs) (map_of xs)"
by (rule map_iterator_I[of "rev xs"])
(simp_all add: rev_map[symmetric] foldri_def)
lemma (in linorder) map_iterator_linord_foldri_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (rev (map fst xs))"
shows "map_iterator_linord (foldri xs) (map_of xs)"
using assms
by (rule_tac map_iterator_linord_I[of "rev xs"])
(simp_all add: rev_map[symmetric] foldri_def)
lemma (in linorder) map_iterator_rev_linord_foldri_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (map fst xs)"
shows "map_iterator_rev_linord (foldri xs) (map_of xs)"
using assms
by (rule_tac map_iterator_rev_linord_I[of "rev xs"])
(simp_all add: rev_map[symmetric] foldri_def)
subsection ‹Iterators over Maps›
text ‹In the following iterator over the key-value pairs of a finite map are called
iterators over maps. Operations for such iterators are presented.›
subsubsection‹Domain Iterator›
text ‹One very simple such operation is iterating over only the keys of the map.›
definition map_iterator_dom where
"map_iterator_dom it = set_iterator_image fst it"
lemma map_iterator_dom_foldli_conv :
"map_iterator_dom (foldli kvs) = foldli (map fst kvs)"
unfolding map_iterator_dom_def set_iterator_image_foldli_conv by simp
lemma map_iterator_genord_dom_correct :
assumes it_OK: "map_iterator_genord it m R"
assumes R'_prop: "⋀k v k' v'. ⟦m k = Some v; m k' = Some v'; R (k, v) (k', v')⟧ ⟹ R' k k'"
shows "set_iterator_genord (map_iterator_dom it) (dom m) R'"
proof -
have pre1: "inj_on fst (map_to_set m)"
unfolding inj_on_def map_to_set_def by simp
from set_iterator_genord_image_correct[OF it_OK pre1, of R'] R'_prop
show ?thesis
unfolding map_iterator_dom_def map_to_set_dom[symmetric]
by (auto simp add: map_to_set_def)
qed
lemma map_iterator_dom_correct :
assumes it_OK: "map_iterator it m"
shows "set_iterator (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_dom_correct)
apply simp_all
done
lemma (in linorder) map_iterator_linord_dom_correct :
assumes it_OK: "map_iterator_linord it m"
shows "set_iterator_linord (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_linord_def set_iterator_map_linord_def
apply (rule_tac map_iterator_genord_dom_correct)
apply assumption
apply auto
done
lemma (in linorder) map_iterator_rev_linord_dom_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "set_iterator_rev_linord (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_rev_linord_def set_iterator_map_rev_linord_def
apply (rule_tac map_iterator_genord_dom_correct)
apply assumption
apply auto
done
subsubsection‹Domain Iterator with Filter›
text ‹More complex is iterating over only the keys such that the key-value pairs satisfy some
property.›
definition map_iterator_dom_filter ::
"('a × 'b ⇒ bool) ⇒ ('a × 'b,'σ) set_iterator ⇒ ('a,'σ) set_iterator" where
"map_iterator_dom_filter P it ≡ set_iterator_image_filter
(λxy. if P xy then Some (fst xy) else None) it"
lemma map_iterator_dom_filter_alt_def [code] :
"map_iterator_dom_filter P it =
(λc f. it c (λkv σ. if P kv then f (fst kv) σ else σ))"
unfolding map_iterator_dom_filter_def set_iterator_image_filter_def
apply (rule ext)
apply (rule ext)
apply (rule arg_cong2[where f="it"])
apply (simp)
apply (simp add: fun_eq_iff split: option.splits)
done
lemma map_iterator_genord_dom_filter_correct :
fixes it :: "('a × 'b, 'σ) set_iterator"
assumes it_OK: "set_iterator_genord it (map_to_set m) R"
assumes R'_prop: "⋀k1 v1 k2 v2.
⟦m k1 = Some v1; P (k1, v1);
m k2 = Some v2; P (k2, v2); R (k1, v1) (k2, v2)⟧ ⟹ R' k1 k2"
shows "set_iterator_genord (map_iterator_dom_filter P it) {k . ∃v. m k = Some v ∧ P (k, v)} R'"
proof -
define g where "g xy = (if P xy then Some (fst xy) else None)" for xy :: "'a × 'b"
note set_iterator_genord_image_filter_correct [OF it_OK, of g R']
have g_eq_Some: "⋀kv k. g kv = Some k ⟷ ((k = fst kv) ∧ P kv)"
unfolding g_def by (auto split: prod.splits option.splits)
have "⋀x1 x2 y. x1 ∈ map_to_set m ⟹ x2 ∈ map_to_set m ⟹
g x1 = Some y ⟹ g x2 = Some y ⟹ x1 = x2"
proof -
fix x1 x2 y
assume x1_in: "x1 ∈ map_to_set m"
and x2_in: "x2 ∈ map_to_set m"
and g1_eq: "g x1 = Some y"
and g2_eq: "g x2 = Some y"
obtain k1 v1 where x1_eq[simp] : "x1 = (k1, v1)" by (rule prod.exhaust)
obtain k2 v2 where x2_eq[simp] : "x2 = (k2, v2)" by (rule prod.exhaust)
from g1_eq g2_eq g_eq_Some have k1_eq: "k1 = k2" by simp
with x1_in x2_in have v1_eq: "v1 = v2"
unfolding map_to_set_def by simp
from k1_eq v1_eq show "x1 = x2" by simp
qed
hence g_inj_on: "inj_on g (map_to_set m ∩ dom g)"
unfolding inj_on_def dom_def by auto
have g_eq_Some: "⋀x y. (g x = Some y) ⟷ (P x ∧ y = (fst x))"
unfolding g_def by auto
have "set_iterator_genord (set_iterator_image_filter g it)
{y. ∃x. x ∈ map_to_set m ∧ g x = Some y} R'"
apply (rule set_iterator_genord_image_filter_correct [OF it_OK, of g R', OF g_inj_on])
apply (insert R'_prop)
apply (auto simp add: g_eq_Some map_to_set_def)
done
thus ?thesis
unfolding map_iterator_dom_filter_def g_def[symmetric]
by (simp add: g_eq_Some map_to_set_def)
qed
lemma map_iterator_dom_filter_correct :
assumes it_OK: "map_iterator it m"
shows "set_iterator (map_iterator_dom_filter P it) {k. ∃v. m k = Some v ∧ P (k, v)}"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_dom_filter_correct)
apply simp_all
done
lemma (in linorder) map_iterator_linord_dom_filter_correct :
assumes it_OK: "map_iterator_linord it m"
shows "set_iterator_linord (map_iterator_dom_filter P it) {k. ∃v. m k = Some v ∧ P (k, v)}"
using assms
unfolding set_iterator_map_linord_def set_iterator_linord_def
apply (rule_tac map_iterator_genord_dom_filter_correct
[where R = "λ(k,_) (k',_). k≤k'"])
apply (simp_all add: set_iterator_def)
done
lemma (in linorder) set_iterator_rev_linord_map_filter_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "set_iterator_rev_linord (map_iterator_dom_filter P it)
{k. ∃v. m k = Some v ∧ P (k, v)}"
using assms
unfolding set_iterator_map_rev_linord_def set_iterator_rev_linord_def
apply (rule_tac map_iterator_genord_dom_filter_correct
[where R = "λ(k,_) (k',_). k≥k'"])
apply (simp_all add: set_iterator_def)
done
subsubsection‹Product for Maps›
definition map_iterator_product where
"map_iterator_product it_a it_b =
set_iterator_image (λkvv'. (fst (fst kvv'), snd kvv'))
(set_iterator_product it_a (λkv. it_b (snd kv)))"
lemma map_iterator_product_foldli_conv :
"map_iterator_product (foldli as) (λa. foldli (bs a)) =
foldli (concat (map (λ(k, v). map (Pair k) (bs v)) as))"
unfolding map_iterator_product_def set_iterator_product_foldli_conv set_iterator_image_foldli_conv
by (simp add: map_concat o_def split_def)
lemma map_iterator_product_alt_def [code] :
"map_iterator_product it_a it_b =
(λc f. it_a c (λa. it_b (snd a) c (λb. f (fst a, b))))"
unfolding map_iterator_product_def set_iterator_product_def set_iterator_image_alt_def
by simp
lemma map_iterator_genord_product_correct :
fixes it_a :: "(('k × 'v),'σ) set_iterator"
fixes it_b :: "'v ⇒ ('e,'σ) set_iterator"
fixes S_a S_b R_a R_b m
assumes it_a: "map_iterator_genord it_a m R_a"
assumes it_b: "⋀k v. m k = Some v ⟹ set_iterator_genord (it_b v) (S_b v) (R_b v)"
assumes R'_prop: "⋀k v u k' v' u'.
m k = Some v ⟹
u ∈ S_b v ⟹
m k' = Some v' ⟹
u' ∈ S_b v' ⟹
if k = k' then R_b v u u'
else R_a (k, v) (k', v') ⟹
R_ab (k, u) (k', u')"
shows "set_iterator_genord (map_iterator_product it_a it_b)
{(k, e) . (∃v. m k = Some v ∧ e ∈ S_b v)} R_ab"
proof -
from it_b have it_b': "⋀kv. kv ∈ map_to_set m ⟹
set_iterator_genord (it_b (snd kv)) (S_b (snd kv)) (R_b (snd kv))"
unfolding map_to_set_def by (case_tac kv, simp)
have "(⋃x∈{(k, v). m k = Some v}. ⋃y∈S_b (snd x). {(x, y)}) = {((k,v), e) .
(m k = Some v) ∧ e ∈ S_b v}" by (auto)
with set_iterator_genord_product_correct [OF it_a, of "λkv. it_b (snd kv)"
"λkv. S_b (snd kv)" "λkv. R_b (snd kv)", OF it_b']
have it_ab': "set_iterator_genord (set_iterator_product it_a (λkv. it_b (snd kv)))
{((k,v), e) . (m k = Some v) ∧ e ∈ S_b v}
(set_iterator_product_order R_a
(λkv. R_b (snd kv)))"
(is "set_iterator_genord ?it_ab' ?S_ab' ?R_ab'")
unfolding map_to_set_def
by (simp add: Sigma_def)
let ?g = "λkvv'. (fst (fst kvv'), snd kvv')"
have inj_g: "inj_on ?g ?S_ab'"
unfolding inj_on_def by simp
have R_ab_OK: "⋀x y.
x ∈ {((k, v), e). m k = Some v ∧ e ∈ S_b v} ⟹
y ∈ {((k, v), e). m k = Some v ∧ e ∈ S_b v} ⟹
set_iterator_product_order R_a (λkv. R_b (snd kv)) x y ⟹
R_ab (fst (fst x), snd x) (fst (fst y), snd y)"
apply (simp add: set_iterator_product_order_def)
apply clarify
apply (simp)
apply (unfold fst_conv snd_conv)
apply (metis R'_prop option.inject)
done
have "(?g ` {((k, v), e). m k = Some v ∧ e ∈ S_b v}) = {(k, e). ∃v. m k = Some v ∧ e ∈ S_b v}"
by (simp add: image_iff set_eq_iff)
with set_iterator_genord_image_correct [OF it_ab' inj_g, of R_ab, OF R_ab_OK]
show ?thesis
by (simp add: map_iterator_product_def)
qed
lemma map_iterator_product_correct :
assumes it_a: "map_iterator it_a m"
assumes it_b: "⋀k v. m k = Some v ⟹ set_iterator (it_b v) (S_b v)"
shows "set_iterator (map_iterator_product it_a it_b)
{(k, e) . (∃v. m k = Some v ∧ e ∈ S_b v)}"
proof -
note res' = map_iterator_genord_product_correct [OF it_a[unfolded set_iterator_def],
of it_b S_b "λ_ _ _. True"]
note res = set_iterator_intro [OF res']
with it_b show ?thesis unfolding set_iterator_def by simp
qed
subsubsection‹Key Filter›
definition map_iterator_key_filter ::
"('a ⇒ bool) ⇒ ('a × 'b,'σ) set_iterator ⇒ ('a × 'b,'σ) set_iterator" where
"map_iterator_key_filter P ≡ set_iterator_filter (P ∘ fst)"
lemma map_iterator_key_filter_foldli_conv :
"map_iterator_key_filter P (foldli kvs) = foldli (filter (λ(k, v). P k) kvs)"
unfolding map_iterator_key_filter_def set_iterator_filter_foldli_conv o_def split_def
by simp
lemma map_iterator_key_filter_alt_def [code] :
"map_iterator_key_filter P it = (λc f. it c (λx σ. if P (fst x) then f x σ else σ))"
unfolding map_iterator_key_filter_def set_iterator_filter_alt_def
set_iterator_image_filter_def by simp
lemma map_iterator_genord_key_filter_correct :
fixes it :: "('a × 'b, 'σ) set_iterator"
assumes it_OK: "map_iterator_genord it m R"
shows "map_iterator_genord (map_iterator_key_filter P it) (m |` {k . P k}) R"
proof -
from set_iterator_genord_filter_correct [OF it_OK, of "P ∘ fst",
folded map_iterator_key_filter_def]
have step1: "set_iterator_genord (map_iterator_key_filter P it)
{x ∈ map_to_set m. (P ∘ fst) x} R"
by simp
have "{x ∈ map_to_set m. (P ∘ fst) x} = map_to_set (m |` {k . P k})"
unfolding map_to_set_def restrict_map_def
by (auto split: if_splits)
with step1 show ?thesis by simp
qed
lemma map_iterator_key_filter_correct :
assumes it_OK: "map_iterator it m"
shows "set_iterator (map_iterator_key_filter P it) (map_to_set (m |` {k . P k}))"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_key_filter_correct)
apply simp_all
done
end
Theory Proper_Iterator
section ‹Proper Iterators›
theory Proper_Iterator
imports
SetIteratorOperations
Automatic_Refinement.Refine_Lib
begin
text ‹
Proper iterators provide a way to obtain polymorphic iterators even
inside locale contexts.
For this purpose, an iterator that converts the set to a list is fixed
inside the locale, and polymorphic iterators are described by folding
over the generated list.
In order to ensure efficiency, it is shown that folding over the generated
list is equivalent to directly iterating over the set, and this equivalence
is set up as a code preprocessing rule.
›
subsection ‹Proper Iterators›
text ‹A proper iterator can be expressed as a fold over a list, where
the list does only depend on the set. In particular, it does not depend
on the type of the state. We express this by the following definition,
using two iterators with different types:›
definition proper_it
:: "('x,'σ1) set_iterator ⇒ ('x,'σ2) set_iterator ⇒ bool"
where "proper_it it it' ≡ (∃l. it=foldli l ∧ it'=foldli l)"
lemma proper_itI[intro?]:
fixes it :: "('x,'σ1) set_iterator"
and it' :: "('x,'σ2) set_iterator"
assumes "it=foldli l ∧ it'=foldli l"
shows "proper_it it it'"
using assms unfolding proper_it_def by auto
lemma proper_itE:
fixes it :: "('x,'σ1) set_iterator"
and it' :: "('x,'σ2) set_iterator"
assumes "proper_it it it'"
obtains l where "it=foldli l" and "it'=foldli l"
using assms unfolding proper_it_def by auto
lemma proper_it_parE:
fixes it :: "'a ⇒ ('x,'σ1) set_iterator"
and it' :: "'a ⇒ ('x,'σ2) set_iterator"
assumes "∀x. proper_it (it x) (it' x)"
obtains f where "it = (λx. foldli (f x))" and "it' = (λx. foldli (f x))"
using assms unfolding proper_it_def
by metis
definition
proper_it'
where "proper_it' it it' ≡ ∀s. proper_it (it s) (it' s)"
lemma proper_it'I:
"⟦⋀s. proper_it (it s) (it' s)⟧ ⟹ proper_it' it it'"
unfolding proper_it'_def by blast
lemma proper_it'D:
"proper_it' it it' ⟹ proper_it (it s) (it' s)"
unfolding proper_it'_def by blast
subsubsection ‹Properness Preservation›
ML ‹
structure Icf_Proper_Iterator = struct
structure icf_proper_iteratorI = Named_Thms
( val name = @{binding icf_proper_iteratorI_raw}
val description = "ICF (internal): Rules to show properness of iterators" )
val get = icf_proper_iteratorI.get
fun add_thm thm = icf_proper_iteratorI.add_thm thm
val add = Thm.declaration_attribute add_thm
fun del_thm thm = icf_proper_iteratorI.del_thm thm
val del = Thm.declaration_attribute del_thm
val setup = I
#> icf_proper_iteratorI.setup
#> Attrib.setup @{binding icf_proper_iteratorI}
(Attrib.add_del add del)
("ICF: Rules to show properness of iterators")
#> Global_Theory.add_thms_dynamic (@{binding icf_proper_iteratorI},
get o Context.proof_of
)
end
›
setup ‹Icf_Proper_Iterator.setup›
lemma proper_iterator_trigger:
"proper_it it it' ⟹ proper_it it it'"
"proper_it' itf itf' ⟹ proper_it' itf itf'" .
declaration ‹
Tagged_Solver.declare_solver @{thms proper_iterator_trigger}
@{binding proper_iterator} "Proper iterator solver"
(fn ctxt => REPEAT_ALL_NEW (resolve_tac ctxt (Icf_Proper_Iterator.get ctxt)))
›
lemma pi_foldli[icf_proper_iteratorI]:
"proper_it (foldli l :: ('a,'σ) set_iterator) (foldli l)"
unfolding proper_it_def
by auto
lemma pi_foldri[icf_proper_iteratorI]:
"proper_it (foldri l :: ('a,'σ) set_iterator) (foldri l)"
unfolding proper_it_def foldri_def by auto
lemma pi'_foldli[icf_proper_iteratorI]:
"proper_it' (foldli o tsl) (foldli o tsl)"
apply (clarsimp simp add: proper_it'_def)
apply (tagged_solver)
done
lemma pi'_foldri[icf_proper_iteratorI]:
"proper_it' (foldri o tsl) (foldri o tsl)"
apply (clarsimp simp add: proper_it'_def)
apply (tagged_solver)
done
text ‹Iterator combinators preserve properness›
lemma pi_emp[icf_proper_iteratorI]:
"proper_it set_iterator_emp set_iterator_emp"
unfolding proper_it_def set_iterator_emp_def[abs_def]
by (auto intro!: ext exI[where x="[]"])
lemma pi_sng[icf_proper_iteratorI]:
"proper_it (set_iterator_sng x) (set_iterator_sng x)"
unfolding proper_it_def set_iterator_sng_def[abs_def]
by (auto intro!: ext exI[where x="[x]"])
lemma pi_union[icf_proper_iteratorI]:
assumes PA: "proper_it it_a it_a'"
assumes PB: "proper_it it_b it_b'"
shows "proper_it (set_iterator_union it_a it_b)
(set_iterator_union it_a' it_b')"
unfolding set_iterator_union_def
apply (rule proper_itE[OF PA])
apply (rule proper_itE[OF PB])
apply (rule_tac l="l@la" in proper_itI)
apply simp
apply (intro conjI ext)
apply (simp_all add: foldli_append)
done
lemma pi_product[icf_proper_iteratorI]:
fixes it_a :: "('a,'σa) set_iterator"
fixes it_b :: "'a ⇒ ('b,'σa) set_iterator"
assumes PA: "proper_it it_a it_a'"
and PB: "⋀x. proper_it (it_b x) (it_b' x)"
shows "proper_it (set_iterator_product it_a it_b)
(set_iterator_product it_a' it_b')"
proof -
from PB have PB': "∀x. proper_it (it_b x) (it_b' x)" ..
show ?thesis
unfolding proper_it_def
apply (rule proper_itE[OF PA])
apply (rule proper_it_parE[OF PB'])
apply (auto simp add: set_iterator_product_foldli_conv)
done
qed
lemma pi_image_filter[icf_proper_iteratorI]:
fixes it :: "('x,'σ1) set_iterator"
and it' :: "('x,'σ2) set_iterator"
and g :: "'x ⇒ 'y option"
assumes P: "proper_it it it'"
shows "proper_it (set_iterator_image_filter g it)
(set_iterator_image_filter g it')"
unfolding proper_it_def
apply (rule proper_itE[OF P])
apply (auto simp: set_iterator_image_filter_foldli_conv)
done
lemma pi_filter[icf_proper_iteratorI]:
assumes P: "proper_it it it'"
shows "proper_it (set_iterator_filter P it)
(set_iterator_filter P it')"
unfolding proper_it_def
apply (rule proper_itE[OF P])
by (auto simp: set_iterator_filter_foldli_conv)
lemma pi_image[icf_proper_iteratorI]:
assumes P: "proper_it it it'"
shows "proper_it (set_iterator_image g it)
(set_iterator_image g it')"
unfolding proper_it_def
apply (rule proper_itE[OF P])
by (auto simp: set_iterator_image_foldli_conv)
lemma pi_dom[icf_proper_iteratorI]:
assumes P: "proper_it it it'"
shows "proper_it (map_iterator_dom it)
(map_iterator_dom it')"
unfolding proper_it_def
apply (rule proper_itE[OF P])
by (auto simp: map_iterator_dom_foldli_conv)
lemma set_iterator_product_eq2:
assumes "∀a∈set la. itb a = itb' a"
shows "set_iterator_product (foldli la) itb
= set_iterator_product (foldli la) itb'"
proof (intro ext)
fix c f σ
show "set_iterator_product (foldli la) itb c f σ
= set_iterator_product (foldli la) itb' c f σ"
using assms
unfolding set_iterator_product_def
apply (induct la arbitrary: σ)
apply (auto)
done
qed
subsubsection ‹Optimizing Folds›
text ‹
Using an iterator to create a list. The optimizations will
match the pattern ‹foldli (it_to_list it s)›
›
definition "it_to_list it s ≡ (it s) (λ_. True) (λx l. l@[x]) []"
lemma map_it_to_list_genord_correct:
assumes A: "map_iterator_genord (it s) m (λ(k,_) (k',_). R k k')"
shows "map_of (it_to_list it s) = m
∧ distinct (map fst (it_to_list it s))
∧ sorted_wrt R ((map fst (it_to_list it s)))"
unfolding it_to_list_def
apply (rule map_iterator_genord_rule_insert_P[OF A, where I="
λit l. map_of l = m |` it
∧ distinct (map fst l)
∧ sorted_wrt R ((map fst l))
"])
apply auto
apply (auto simp: restrict_map_def) []
apply (metis Some_eq_map_of_iff restrict_map_eq(2))
apply (auto simp add: sorted_wrt_append)
by (metis (lifting) restrict_map_eq(2) weak_map_of_SomeI)
lemma (in linorder) map_it_to_list_linord_correct:
assumes A: "map_iterator_linord (it s) m"
shows "map_of (it_to_list it s) = m
∧ distinct (map fst (it_to_list it s))
∧ sorted ((map fst (it_to_list it s)))"
using map_it_to_list_genord_correct[where it=it,
OF A[unfolded set_iterator_map_linord_def]]
by (simp add: sorted_sorted_wrt)
lemma (in linorder) map_it_to_list_rev_linord_correct:
assumes A: "map_iterator_rev_linord (it s) m"
shows "map_of (it_to_list it s) = m
∧ distinct (map fst (it_to_list it s))
∧ sorted (rev (map fst (it_to_list it s)))"
using map_it_to_list_genord_correct[where it=it,
OF A[unfolded set_iterator_map_rev_linord_def]]
by simp
end
Theory It_to_It
theory It_to_It
imports
Proper_Iterator
begin
lemma proper_it_fold:
"proper_it it it' ⟹ foldli (it (λ_. True) (λx l. l@[x]) []) = it'"
unfolding proper_it_def by auto
lemma proper_it_unfold:
"proper_it it it' ⟹ it' = foldli (it (λ_. True) (λx l. l@[x]) [])"
unfolding proper_it_def by auto
text ‹The following constant converts an iterator over list-state
to an iterator over arbitrary state›
definition it_to_it :: "('x,'x list) set_iterator ⇒ ('x,'σ) set_iterator"
where [code del]: "it_to_it it
≡ (foldli (it (λ_. True) (λx l. l@[x]) []))"
lemma pi_it_to_it[icf_proper_iteratorI]: "proper_it (it_to_it I) (it_to_it I)"
unfolding it_to_it_def by (rule pi_foldli)
text ‹In case of a proper iterator, it is equivalent to direct iteration›
lemma it_to_it_fold: "proper_it it (it'::('x,'σ) set_iterator)
⟹ it_to_it it = it'"
unfolding it_to_it_def
by (simp add: proper_it_fold)
lemma it_to_it_map_fold:
assumes P: "proper_it it it'"
shows "it_to_it (λc f. it c (f ∘ f')) = (λc f. it' c (f o f'))"
apply (rule proper_itE[OF P])
unfolding it_to_it_def
apply (intro ext)
apply (simp add: foldli_foldl map_by_foldl foldli_map)
done
lemma it_to_it_fold': "proper_it' it (it'::'s ⇒ ('x,'σ) set_iterator)
⟹ it_to_it (it s) = (it' s)"
by (drule proper_it'D) (rule it_to_it_fold)
lemma it_to_it_map_fold':
assumes P: "proper_it' it it'"
shows "it_to_it (λc f. it s c (f ∘ f')) = (λc f. it' s c (f o f'))"
using P[THEN proper_it'D] by (rule it_to_it_map_fold)
text ‹This locale wraps up the setup of a proper iterator for use
with ‹it_to_it›.›
locale proper_it_loc =
fixes it :: "'s ⇒ ('x,'x list) set_iterator"
and it' :: "'s ⇒ ('x,'σ) set_iterator"
assumes proper': "proper_it' it it'"
begin
lemma proper: "proper_it (it s) (it' s)"
using proper' by (rule proper_it'D)
lemmas it_to_it_code_unfold[code_unfold] = it_to_it_fold[OF proper]
end
subsubsection ‹Correctness›
text ‹The polymorphic iterator is a valid iterator again.›
lemma it_to_it_genord_correct:
assumes "set_iterator_genord (it::('x,'x list) set_iterator) S R"
shows "set_iterator_genord ((it_to_it it)::('x,'σ) set_iterator) S R"
proof -
interpret set_iterator_genord it S R by fact
show ?thesis
apply (unfold_locales)
unfolding it_to_it_def
using foldli_transform
by auto
qed
lemma it_to_it_linord_correct:
assumes "set_iterator_linord (it::('x::linorder,'x list) set_iterator) S"
shows "set_iterator_linord ((it_to_it it)::('x,'σ) set_iterator) S"
using assms
unfolding set_iterator_linord_def
by (rule it_to_it_genord_correct)
lemma it_to_it_rev_linord_correct:
assumes "set_iterator_rev_linord (it::('x::linorder,'x list) set_iterator) S"
shows "set_iterator_rev_linord ((it_to_it it)::('x,'σ) set_iterator) S"
using assms
unfolding set_iterator_rev_linord_def
by (rule it_to_it_genord_correct)
lemma it_to_it_correct:
assumes "set_iterator (it::('x,'x list) set_iterator) S"
shows "set_iterator ((it_to_it it)::('x,'σ) set_iterator) S"
using assms
unfolding set_iterator_def
by (rule it_to_it_genord_correct)
lemma it_to_it_map_genord_correct:
assumes "map_iterator_genord (it::('u,'v,('u×'v) list) map_iterator) S R"
shows "map_iterator_genord ((it_to_it it)::('u,'v,'σ) map_iterator) S R"
using assms by (rule it_to_it_genord_correct)
lemma it_to_it_map_linord_correct:
assumes "map_iterator_linord (it::('u::linorder,'v,('u×'v) list) map_iterator) S"
shows "map_iterator_linord ((it_to_it it)::('u,'v,'σ) map_iterator) S"
using assms unfolding set_iterator_map_linord_def by (rule it_to_it_genord_correct)
lemma it_to_it_map_rev_linord_correct:
assumes
"map_iterator_rev_linord (it::('u::linorder,'v,('u×'v) list) map_iterator) S"
shows "map_iterator_rev_linord ((it_to_it it)::('u,'v,'σ) map_iterator) S"
using assms unfolding set_iterator_map_rev_linord_def
by (rule it_to_it_genord_correct)
lemma it_to_it_map_correct:
assumes "map_iterator (it::('u,'v,('u×'v) list) map_iterator) S"
shows "map_iterator ((it_to_it it)::('u,'v,'σ) map_iterator) S"
using assms by (rule it_to_it_correct)
end
Theory SetIteratorGA
section ‹General Algorithms for Iterators over Finite Sets›
theory SetIteratorGA
imports Main SetIteratorOperations
begin
subsection ‹Quantification›
definition iterate_ball where
"iterate_ball (it::('x,bool) set_iterator) P = it id (λx σ. P x) True"
lemma iterate_ball_correct :
assumes it: "set_iterator it S0"
shows "iterate_ball it P = (∀x∈S0. P x)"
unfolding iterate_ball_def
apply (rule set_iterator_rule_P [OF it,
where I = "λS σ. σ = (∀x∈S0-S. P x)"])
apply auto
done
definition iterate_bex where
"iterate_bex (it::('x,bool) set_iterator) P = it (λσ. ¬σ) (λx σ. P x) False"
lemma iterate_bex_correct :
assumes it: "set_iterator it S0"
shows "iterate_bex it P = (∃x∈S0. P x)"
unfolding iterate_bex_def
apply (rule set_iterator_rule_P [OF it, where I = "λS σ. σ = (∃x∈S0-S. P x)"])
apply auto
done
subsection ‹Iterator to List›
definition iterate_to_list where
"iterate_to_list (it::('x,'x list) set_iterator) = it (λ_. True) (λx σ. x # σ) []"
lemma iterate_to_list_foldli [simp] :
"iterate_to_list (foldli xs) = rev xs"
unfolding iterate_to_list_def
by (induct xs rule: rev_induct, simp_all add: foldli_snoc)
lemma iterate_to_list_genord_correct :
assumes it: "set_iterator_genord it S0 R"
shows "set (iterate_to_list it) = S0 ∧ distinct (iterate_to_list it) ∧
sorted_wrt R (rev (iterate_to_list it))"
using it unfolding set_iterator_genord_foldli_conv by auto
lemma iterate_to_list_correct :
assumes it: "set_iterator it S0"
shows "set (iterate_to_list it) = S0 ∧ distinct (iterate_to_list it)"
using iterate_to_list_genord_correct [OF it[unfolded set_iterator_def]]
by simp
lemma (in linorder) iterate_to_list_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_linord it S0"
shows "set (iterate_to_list it) = S0 ∧ distinct (iterate_to_list it) ∧
sorted (rev (iterate_to_list it))"
using it_OK unfolding set_iterator_linord_foldli_conv by auto
lemma (in linorder) iterate_to_list_rev_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_rev_linord it S0"
shows "set (iterate_to_list it) = S0 ∧ distinct (iterate_to_list it) ∧
sorted (iterate_to_list it)"
using it_OK unfolding set_iterator_rev_linord_foldli_conv by auto
lemma (in linorder) iterate_to_list_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "map_of (iterate_to_list it) = m ∧ distinct (map fst (iterate_to_list it)) ∧
sorted (map fst (rev (iterate_to_list it)))"
using it_OK unfolding map_iterator_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])
lemma (in linorder) iterate_to_list_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "map_of (iterate_to_list it) = m ∧ distinct (map fst (iterate_to_list it)) ∧
sorted (map fst (iterate_to_list it))"
using it_OK unfolding map_iterator_rev_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])
subsection ‹Size›
lemma set_iterator_finite :
assumes it: "set_iterator it S0"
shows "finite S0"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]] .
lemma map_iterator_finite :
assumes it: "map_iterator it m"
shows "finite (dom m)"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
by (simp add: finite_map_to_set)
definition iterate_size where
"iterate_size (it::('x,nat) set_iterator) = it (λ_. True) (λx σ. Suc σ) 0"
lemma iterate_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_size it = card S0 ∧ finite S0"
unfolding iterate_size_def
apply (rule_tac set_iterator_rule_insert_P [OF it,
where I = "λS σ. σ = card S ∧ finite S"])
apply auto
done
definition iterate_size_abort where
"iterate_size_abort (it::('x,nat) set_iterator) n = it (λσ. σ < n) (λx σ. Suc σ) 0"
lemma iterate_size_abort_correct :
assumes it: "set_iterator it S0"
shows "iterate_size_abort it n = (min n (card S0)) ∧ finite S0"
unfolding iterate_size_abort_def
proof (rule set_iterator_rule_insert_P [OF it,
where I = "λS σ. σ = (min n (card S)) ∧ finite S"], goal_cases)
case (4 σ S)
assume "S ⊆ S0" "S ≠ S0" "¬ σ < n" "σ = min n (card S) ∧ finite S"
from ‹σ = min n (card S) ∧ finite S› ‹¬ σ < n›
have "σ = n" "n ≤ card S"
by (auto simp add: min_less_iff_disj)
note fin_S0 = set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
from card_mono [OF fin_S0 ‹S ⊆ S0›] have "card S ≤ card S0" .
with ‹σ = n› ‹n ≤ card S› fin_S0
show "σ = min n (card S0) ∧ finite S0" by simp
qed simp_all
subsection ‹Emptyness Check›
definition iterate_is_empty_by_size where
"iterate_is_empty_by_size it = (iterate_size_abort it 1 = 0)"
lemma iterate_is_empty_by_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty_by_size it = (S0 = {})"
using iterate_size_abort_correct[OF it, of 1]
unfolding iterate_is_empty_by_size_def
by (cases "card S0") auto
definition iterate_is_empty where
"iterate_is_empty (it::('x,bool) set_iterator) = (it (λb. b) (λ_ _. False) True)"
lemma iterate_is_empty_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty it = (S0 = {})"
unfolding iterate_is_empty_def
apply (rule set_iterator_rule_insert_P [OF it,
where I = "λS σ. σ ⟷ S = {}"])
apply auto
done
subsection ‹Check for singleton Sets›
definition iterate_is_sng where
"iterate_is_sng it = (iterate_size_abort it 2 = 1)"
lemma iterate_is_sng_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_sng it = (card S0 = 1)"
using iterate_size_abort_correct[OF it, of 2]
unfolding iterate_is_sng_def
apply (cases "card S0", simp, rename_tac n')
apply (case_tac n')
apply auto
done
subsection ‹Selection›
definition iterate_sel where
"iterate_sel (it::('x,'y option) set_iterator) f = it (λσ. σ = None) (λx σ. f x) None"
lemma iterate_sel_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel it f = None ⟷ (∀x∈S0. (f x = None))"
"iterate_sel it f = Some y ⟹ (∃x ∈ S0. f x = Some y ∧ (∀x' ∈ S0-{x}. ∀y. f x' = Some y' ⟶ R x x'))"
proof -
show "iterate_sel it f = None ⟷ (∀x∈S0. (f x = None))"
unfolding iterate_sel_def
apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
where I = "λS σ. (σ = None) ⟷ (∀x∈S. (f x = None))"])
apply auto
done
next
have "iterate_sel it f = Some y ⟶ (∃x ∈ S0. f x = Some y ∧ (∀x' ∈ S0-{x}. ∀y'. f x' = Some y' ⟶ R x x'))"
unfolding iterate_sel_def
apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
where I = "λS σ. (∀y. σ = Some y ⟶ (∃x ∈ S. f x = Some y ∧ (∀x' ∈ S-{x}.∀y'. f x' = Some y' ⟶ R x x'))) ∧
((σ = None) ⟷ (∀x∈S. f x = None))"])
apply simp
apply (auto simp add: Bex_def subset_iff Ball_def)
apply metis
done
moreover assume "iterate_sel it f = Some y"
finally show "(∃x ∈ S0. f x = Some y ∧ (∀x' ∈ S0-{x}. ∀y. f x' = Some y' ⟶ R x x'))" by blast
qed
definition iterate_sel_no_map where
"iterate_sel_no_map it P = iterate_sel it (λx. if P x then Some x else None)"
lemmas iterate_sel_no_map_alt_def = iterate_sel_no_map_def[unfolded iterate_sel_def, code]
lemma iterate_sel_no_map_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ (x ∈ S0 ∧ P x ∧ (∀x' ∈ S0-{x}. P x' ⟶ R x x'))"
unfolding iterate_sel_no_map_def
using iterate_sel_genord_correct[OF it_OK, of "λx. if P x then Some x else None"]
apply (simp_all add: Bex_def)
apply (metis option.inject option.simps(2))
done
lemma iterate_sel_no_map_correct :
assumes it_OK: "set_iterator it S0"
shows "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ x ∈ S0 ∧ P x"
proof -
note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
thus "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ x ∈ S0 ∧ P x"
by simp_all
qed
lemma (in linorder) iterate_sel_no_map_linord_correct :
assumes it_OK: "set_iterator_linord it S0"
shows "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ (x ∈ S0 ∧ P x ∧ (∀x'∈S0. P x' ⟶ x ≤ x'))"
proof -
note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_linord_def], of P]
thus "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ (x ∈ S0 ∧ P x ∧ (∀x'∈S0. P x' ⟶ x ≤ x'))"
by auto
qed
lemma (in linorder) iterate_sel_no_map_rev_linord_correct :
assumes it_OK: "set_iterator_rev_linord it S0"
shows "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ (x ∈ S0 ∧ P x ∧ (∀x'∈S0. P x' ⟶ x' ≤ x))"
proof -
note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_rev_linord_def], of P]
thus "iterate_sel_no_map it P = None ⟷ (∀x∈S0. ¬(P x))"
"iterate_sel_no_map it P = Some x ⟹ (x ∈ S0 ∧ P x ∧ (∀x'∈S0. P x' ⟶ x' ≤ x))"
by auto
qed
lemma iterate_sel_no_map_map_correct :
assumes it_OK: "map_iterator it m"
shows "iterate_sel_no_map it P = None ⟷ (∀k v. m k = Some v ⟶ ¬(P (k, v)))"
"iterate_sel_no_map it P = Some (k, v) ⟹ (m k = Some v ∧ P (k, v))"
proof -
note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
thus "iterate_sel_no_map it P = None ⟷ (∀k v. m k = Some v ⟶ ¬(P (k, v)))"
"iterate_sel_no_map it P = Some (k, v) ⟹ (m k = Some v ∧ P (k, v))"
by (auto simp add: map_to_set_def)
qed
lemma (in linorder) iterate_sel_no_map_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "iterate_sel_no_map it P = None ⟷ (∀k v. m k = Some v ⟶ ¬(P (k, v)))"
"iterate_sel_no_map it P = Some (k, v) ⟹ (m k = Some v ∧ P (k, v) ∧ (∀k' v' . m k' = Some v' ∧
P (k', v') ⟶ k ≤ k'))"
proof -
note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_linord_def], of P]
thus "iterate_sel_no_map it P = None ⟷ (∀k v. m k = Some v ⟶ ¬(P (k, v)))"
"iterate_sel_no_map it P = Some (k, v) ⟹ (m k = Some v ∧ P (k, v) ∧ (∀k' v' . m k' = Some v' ∧
P (k', v') ⟶ k ≤ k'))"
apply (auto simp add: map_to_set_def Ball_def)
done
qed
lemma (in linorder) iterate_sel_no_map_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "iterate_sel_no_map it P = None ⟷ (∀k v. m k = Some v ⟶ ¬(P (k, v)))"
"iterate_sel_no_map it P = Some (k, v) ⟹ (m k = Some v ∧ P (k, v) ∧ (∀k' v' . m k' = Some v' ∧
P (k', v') ⟶ k' ≤ k))"
proof -
note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_rev_linord_def], of P]
thus "iterate_sel_no_map it P = None ⟷ (∀k v. m k = Some v ⟶ ¬(P (k, v)))"
"iterate_sel_no_map it P = Some (k, v) ⟹ (m k = Some v ∧ P (k, v) ∧ (∀k' v' . m k' = Some v' ∧
P (k', v') ⟶ k' ≤ k))"
apply (auto simp add: map_to_set_def Ball_def)
done
qed
subsection ‹Creating ordered iterators›
text ‹One can transform an iterator into an ordered one by converting it to list,
sorting this list and then converting back to an iterator. In general, this brute-force
method is inefficient, though.›
definition iterator_to_ordered_iterator where
"iterator_to_ordered_iterator sort_fun it =
foldli (sort_fun (iterate_to_list it))"
lemma iterator_to_ordered_iterator_correct :
assumes sort_fun_OK: "⋀l. sorted_wrt R (sort_fun l) ∧ mset (sort_fun l) = mset l"
and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator sort_fun it) S0 R"
proof -
define l where "l = iterate_to_list it"
have l_props: "set l = S0" "distinct l"
using iterate_to_list_correct [OF it_OK, folded l_def] by simp_all
with sort_fun_OK[of l] have sort_l_props:
"sorted_wrt R (sort_fun l)"
"set (sort_fun l) = S0" "distinct (sort_fun l)"
apply (simp_all)
apply (metis set_mset_mset)
apply (metis distinct_count_atmost_1 set_mset_mset)
done
show ?thesis
apply (rule set_iterator_genord_I[of "sort_fun l"])
apply (simp_all add: sort_l_props iterator_to_ordered_iterator_def l_def[symmetric])
done
qed
definition iterator_to_ordered_iterator_quicksort where
"iterator_to_ordered_iterator_quicksort R it =
iterator_to_ordered_iterator (quicksort_by_rel R []) it"
lemmas iterator_to_ordered_iterator_quicksort_code[code] =
iterator_to_ordered_iterator_quicksort_def[unfolded iterator_to_ordered_iterator_def]
lemma iterator_to_ordered_iterator_quicksort_correct :
assumes lin : "⋀x y. (R x y) ∨ (R y x)"
and trans_R: "⋀x y z. R x y ⟹ R y z ⟹ R x z"
and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_quicksort R it) S0 R"
unfolding iterator_to_ordered_iterator_quicksort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_wrt_quicksort_by_rel[OF lin trans_R])
done
definition iterator_to_ordered_iterator_mergesort where
"iterator_to_ordered_iterator_mergesort R it =
iterator_to_ordered_iterator (mergesort_by_rel R) it"
lemmas iterator_to_ordered_iterator_mergesort_code[code] =
iterator_to_ordered_iterator_mergesort_def[unfolded iterator_to_ordered_iterator_def]
lemma iterator_to_ordered_iterator_mergesort_correct :
assumes lin : "⋀x y. (R x y) ∨ (R y x)"
and trans_R: "⋀x y z. R x y ⟹ R y z ⟹ R x z"
and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_mergesort R it) S0 R"
unfolding iterator_to_ordered_iterator_mergesort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_wrt_mergesort_by_rel[OF lin trans_R])
done
end
Theory Gen_Iterator
section ‹\isaheader{Iterators}›
theory Gen_Iterator
imports Refine_Monadic.Refine_Monadic Proper_Iterator
begin
text ‹
Iterators are realized by to-list functions followed by folding.
A post-optimization step then replaces these constructions by
real iterators.›
lemma param_it_to_list[param]: "(it_to_list,it_to_list) ∈
(Rs → (Ra → bool_rel) →
(Rb → ⟨Rb⟩list_rel → ⟨Rb⟩list_rel) → ⟨Rc⟩list_rel → Rd) → Rs → Rd"
unfolding it_to_list_def[abs_def]
by parametricity
definition key_rel :: "('k ⇒ 'k ⇒ bool) ⇒ ('k×'v) ⇒ ('k×'v) ⇒ bool"
where "key_rel R a b ≡ R (fst a) (fst b)"
lemma key_rel_UNIV[simp]: "key_rel (λ_ _. True) = (λ_ _. True)"
unfolding key_rel_def[abs_def] by auto
subsection ‹Setup for Autoref›
text ‹Default pattern rules for ‹it_to_sorted_list››
definition "set_to_sorted_list R S ≡ it_to_sorted_list R S"
lemma set_to_sorted_list_itype[autoref_itype]:
"set_to_sorted_list R ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨⟨I⟩⇩ii_list⟩⇩ii_nres"
by simp
context begin interpretation autoref_syn .
lemma set_to_sorted_list_pat[autoref_op_pat]:
"it_to_sorted_list R S ≡ OP (set_to_sorted_list R) S"
unfolding set_to_sorted_list_def[abs_def] by auto
end
definition "map_to_sorted_list R M
≡ it_to_sorted_list (key_rel R) (map_to_set M)"
lemma map_to_sorted_list_itype[autoref_itype]:
"map_to_sorted_list R ::⇩i ⟨Rk,Rv⟩⇩ii_map →⇩i ⟨⟨⟨Rk,Rv⟩⇩ii_prod⟩⇩ii_list⟩⇩ii_nres"
by simp
context begin interpretation autoref_syn .
lemma map_to_sorted_list_pat[autoref_op_pat]:
"it_to_sorted_list (key_rel R) (map_to_set M)
≡ OP (map_to_sorted_list R) M"
"it_to_sorted_list (λ_ _. True) (map_to_set M)
≡ OP (map_to_sorted_list (λ_ _. True)) M"
unfolding map_to_sorted_list_def[abs_def] by auto
end
subsection ‹Set iterators›
definition "is_set_to_sorted_list ordR Rk Rs tsl ≡ ∀s s'.
(s,s')∈⟨Rk⟩Rs
⟶ ( ∃l'. (tsl s,l')∈⟨Rk⟩list_rel
∧ RETURN l' ≤ it_to_sorted_list ordR s')"
definition "is_set_to_list ≡ is_set_to_sorted_list (λ_ _. True)"
lemma is_set_to_sorted_listE:
assumes "is_set_to_sorted_list ordR Rk Rs tsl"
assumes "(s,s')∈⟨Rk⟩Rs"
obtains l' where "(tsl s,l')∈⟨Rk⟩list_rel"
and "RETURN l' ≤ it_to_sorted_list ordR s'"
using assms unfolding is_set_to_sorted_list_def by blast
lemma it_to_sorted_list_weaken:
"R≤R' ⟹ it_to_sorted_list R s ≤ it_to_sorted_list R' s"
unfolding it_to_sorted_list_def
by (auto intro!: sorted_wrt_mono_rel[where P=R])
lemma set_to_list_by_set_to_sorted_list[autoref_ga_rules]:
assumes "GEN_ALGO_tag (is_set_to_sorted_list ordR Rk Rs tsl)"
shows "is_set_to_list Rk Rs tsl"
using assms
unfolding is_set_to_list_def is_set_to_sorted_list_def autoref_tag_defs
apply (safe)
apply (drule spec, drule spec, drule (1) mp)
apply (elim exE conjE)
apply (rule exI, rule conjI, assumption)
apply (rule order_trans, assumption)
apply (rule it_to_sorted_list_weaken)
by blast
definition "det_fold_set R c f σ result ≡
∀l. distinct l ∧ sorted_wrt R l ⟶ foldli l c f σ = result (set l)"
lemma det_fold_setI[intro?]:
assumes "⋀l. ⟦distinct l; sorted_wrt R l⟧
⟹ foldli l c f σ = result (set l)"
shows "det_fold_set R c f σ result"
using assms unfolding det_fold_set_def by auto
text ‹Template lemma for generic algorithm using set iterator›
lemma det_fold_sorted_set:
assumes 1: "det_fold_set ordR c' f' σ' result"
assumes 2: "is_set_to_sorted_list ordR Rk Rs tsl"
assumes SREF[param]: "(s,s')∈⟨Rk⟩Rs"
assumes [param]: "(c,c')∈Rσ→Id"
assumes [param]: "(f,f')∈Rk → Rσ → Rσ"
assumes [param]: "(σ,σ')∈Rσ"
shows "(foldli (tsl s) c f σ, result s') ∈ Rσ"
proof -
obtain tsl' where
[param]: "(tsl s,tsl') ∈ ⟨Rk⟩list_rel"
and IT: "RETURN tsl' ≤ it_to_sorted_list ordR s'"
using 2 SREF
by (rule is_set_to_sorted_listE)
have "(foldli (tsl s) c f σ, foldli tsl' c' f' σ') ∈ Rσ"
by parametricity
also have "foldli tsl' c' f' σ' = result s'"
using 1 IT
unfolding det_fold_set_def it_to_sorted_list_def
by simp
finally show ?thesis .
qed
lemma det_fold_set:
assumes "det_fold_set (λ_ _. True) c' f' σ' result"
assumes "is_set_to_list Rk Rs tsl"
assumes "(s,s')∈⟨Rk⟩Rs"
assumes "(c,c')∈Rσ→Id"
assumes "(f,f')∈Rk → Rσ → Rσ"
assumes "(σ,σ')∈Rσ"
shows "(foldli (tsl s) c f σ, result s') ∈ Rσ"
using assms
unfolding is_set_to_list_def
by (rule det_fold_sorted_set)
subsection ‹Map iterators›
text ‹Build relation on keys›
definition "is_map_to_sorted_list ordR Rk Rv Rm tsl ≡ ∀m m'.
(m,m')∈⟨Rk,Rv⟩Rm ⟶ (
∃l'. (tsl m,l')∈⟨⟨Rk,Rv⟩prod_rel⟩list_rel
∧ RETURN l' ≤ it_to_sorted_list (key_rel ordR) (map_to_set m'))"
definition "is_map_to_list Rk Rv Rm tsl
≡ is_map_to_sorted_list (λ_ _. True) Rk Rv Rm tsl"
lemma is_map_to_sorted_listE:
assumes "is_map_to_sorted_list ordR Rk Rv Rm tsl"
assumes "(m,m')∈⟨Rk,Rv⟩Rm"
obtains l' where "(tsl m,l')∈⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
and "RETURN l' ≤ it_to_sorted_list (key_rel ordR) (map_to_set m')"
using assms unfolding is_map_to_sorted_list_def by blast
lemma map_to_list_by_map_to_sorted_list[autoref_ga_rules]:
assumes "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Rv Rm tsl)"
shows "is_map_to_list Rk Rv Rm tsl"
using assms
unfolding is_map_to_list_def is_map_to_sorted_list_def autoref_tag_defs
apply (safe)
apply (drule spec, drule spec, drule (1) mp)
apply (elim exE conjE)
apply (rule exI, rule conjI, assumption)
apply (rule order_trans, assumption)
apply (rule it_to_sorted_list_weaken)
unfolding key_rel_def[abs_def]
by blast
definition "det_fold_map R c f σ result ≡
∀l. distinct (map fst l) ∧ sorted_wrt (key_rel R) l
⟶ foldli l c f σ = result (map_of l)"
lemma det_fold_mapI[intro?]:
assumes "⋀l. ⟦distinct (map fst l); sorted_wrt (key_rel R) l⟧
⟹ foldli l c f σ = result (map_of l)"
shows "det_fold_map R c f σ result"
using assms unfolding det_fold_map_def by auto
lemma det_fold_map_aux:
assumes 1: "⟦distinct (map fst l); sorted_wrt (key_rel R) l ⟧
⟹ foldli l c f σ = result (map_of l)"
assumes 2: "RETURN l ≤ it_to_sorted_list (key_rel R) (map_to_set m)"
shows "foldli l c f σ = result m"
proof -
from 2 have "distinct l" and "set l = map_to_set m"
and SORTED: "sorted_wrt (key_rel R) l"
unfolding it_to_sorted_list_def by simp_all
hence "∀(k,v)∈set l. ∀(k',v')∈set l. k=k' ⟶ v=v'"
apply simp
unfolding map_to_set_def
apply auto
done
with ‹distinct l› have DF: "distinct (map fst l)"
apply (induct l)
apply simp
apply force
done
with ‹set l = map_to_set m› have [simp]: "m = map_of l"
by (metis map_of_map_to_set)
from 1[OF DF SORTED] show ?thesis by simp
qed
text ‹Template lemma for generic algorithm using map iterator›
lemma det_fold_sorted_map:
assumes 1: "det_fold_map ordR c' f' σ' result"
assumes 2: "is_map_to_sorted_list ordR Rk Rv Rm tsl"
assumes MREF[param]: "(m,m')∈⟨Rk,Rv⟩Rm"
assumes [param]: "(c,c')∈Rσ→Id"
assumes [param]: "(f,f')∈⟨Rk,Rv⟩prod_rel → Rσ → Rσ"
assumes [param]: "(σ,σ')∈Rσ"
shows "(foldli (tsl m) c f σ, result m') ∈ Rσ"
proof -
obtain tsl' where
[param]: "(tsl m,tsl') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
and IT: "RETURN tsl' ≤ it_to_sorted_list (key_rel ordR) (map_to_set m')"
using 2 MREF by (rule is_map_to_sorted_listE)
have "(foldli (tsl m) c f σ, foldli tsl' c' f' σ') ∈ Rσ"
by parametricity
also have "foldli tsl' c' f' σ' = result m'"
using det_fold_map_aux[of tsl' ordR c' f' σ' result] 1 IT
unfolding det_fold_map_def
by clarsimp
finally show ?thesis .
qed
lemma det_fold_map:
assumes "det_fold_map (λ_ _. True) c' f' σ' result"
assumes "is_map_to_list Rk Rv Rm tsl"
assumes "(m,m')∈⟨Rk,Rv⟩Rm"
assumes "(c,c')∈Rσ→Id"
assumes "(f,f')∈⟨Rk,Rv⟩prod_rel → Rσ → Rσ"
assumes "(σ,σ')∈Rσ"
shows "(foldli (tsl m) c f σ, result m') ∈ Rσ"
using assms
unfolding is_map_to_list_def
by (rule det_fold_sorted_map)
lemma set_to_sorted_list_by_tsl[autoref_rules]:
assumes "MINOR_PRIO_TAG (- 11)"
assumes TSL: "SIDE_GEN_ALGO (is_set_to_sorted_list R Rk Rs tsl)"
shows "(λs. RETURN (tsl s), set_to_sorted_list R)
∈ ⟨Rk⟩Rs → ⟨⟨Rk⟩list_rel⟩nres_rel"
proof (intro fun_relI nres_relI)
fix s s'
assume "(s,s')∈⟨Rk⟩Rs"
with TSL obtain l' where
R1: "(tsl s, l') ∈ ⟨Rk⟩list_rel"
and R2: "RETURN l' ≤ set_to_sorted_list R s'"
unfolding is_set_to_sorted_list_def set_to_sorted_list_def autoref_tag_defs
by blast
have "RETURN (tsl s) ≤ ⇓(⟨Rk⟩list_rel) (RETURN l')"
by (rule RETURN_refine) fact
also note R2
finally show "RETURN (tsl s) ≤ ⇓ (⟨Rk⟩list_rel) (set_to_sorted_list R s')" .
qed
lemma set_to_list_by_tsl[autoref_rules]:
assumes "MINOR_PRIO_TAG (- 10)"
assumes TSL: "SIDE_GEN_ALGO (is_set_to_list Rk Rs tsl)"
shows "(λs. RETURN (tsl s), set_to_sorted_list (λ_ _. True))
∈ ⟨Rk⟩Rs → ⟨⟨Rk⟩list_rel⟩nres_rel"
using assms(2-) unfolding is_set_to_list_def
by (rule set_to_sorted_list_by_tsl[OF PRIO_TAGI])
lemma map_to_sorted_list_by_tsl[autoref_rules]:
assumes "MINOR_PRIO_TAG (- 11)"
assumes TSL: "SIDE_GEN_ALGO (is_map_to_sorted_list R Rk Rv Rs tsl)"
shows "(λs. RETURN (tsl s), map_to_sorted_list R)
∈ ⟨Rk,Rv⟩Rs → ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩nres_rel"
proof (intro fun_relI nres_relI)
fix s s'
assume "(s,s')∈⟨Rk,Rv⟩Rs"
with TSL obtain l' where
R1: "(tsl s, l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
and R2: "RETURN l' ≤ map_to_sorted_list R s'"
unfolding is_map_to_sorted_list_def map_to_sorted_list_def autoref_tag_defs
by blast
have "RETURN (tsl s) ≤ ⇓(⟨⟨Rk,Rv⟩prod_rel⟩list_rel) (RETURN l')"
apply (rule RETURN_refine)
by fact
also note R2
finally show
"RETURN (tsl s) ≤ ⇓ (⟨⟨Rk,Rv⟩prod_rel⟩list_rel) (map_to_sorted_list R s')" .
qed
lemma map_to_list_by_tsl[autoref_rules]:
assumes "MINOR_PRIO_TAG (- 10)"
assumes TSL: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs tsl)"
shows "(λs. RETURN (tsl s), map_to_sorted_list (λ_ _. True))
∈ ⟨Rk,Rv⟩Rs → ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩nres_rel"
using assms(2-) unfolding is_map_to_list_def
by (rule map_to_sorted_list_by_tsl[OF PRIO_TAGI])
text ‹
TODO/FIXME:
* Integrate mono-prover properly into solver-infrastructure,
i.e. tag a mono-goal.
* Tag iterators, such that, for the mono-prover, we can just convert
a proper iterator back to its foldli-equivalent!
›
lemma proper_it_mono_dres_pair:
assumes PR: "proper_it' it it'"
assumes A: "⋀k v x. f k v x ≤ f' k v x"
shows "
it' s (case_dres False False c) (λ(k,v) s. s ⤜ f k v) σ
≤ it' s (case_dres False False c) (λ(k,v) s. s ⤜ f' k v) σ" (is "?a ≤ ?b")
proof -
from proper_itE[OF PR[THEN proper_it'D]] obtain l where
A_FMT:
"?a = foldli l (case_dres False False c) (λ(k,v) s. s ⤜ f k v) σ"
(is "_ = ?a'")
and B_FMT:
"?b = foldli l (case_dres False False c) (λ(k,v) s. s ⤜ f' k v) σ"
(is "_ = ?b'")
by metis
from A have A': "⋀kv x. case_prod f kv x ≤ case_prod f' kv x"
by auto
note A_FMT
also have
"?a' = foldli l (case_dres False False c) (λkv s. s ⤜ case_prod f kv) σ"
apply (fo_rule fun_cong)
apply (fo_rule arg_cong)
by auto
also note foldli_mono_dres[OF A']
also have
"foldli l (case_dres False False c) (λkv s. s ⤜ case_prod f' kv) σ = ?b'"
apply (fo_rule fun_cong)
apply (fo_rule arg_cong)
by auto
also note B_FMT[symmetric]
finally show ?thesis .
qed
lemma proper_it_mono_dres_pair_flat:
assumes PR: "proper_it' it it'"
assumes A: "⋀k v x. flat_ge (f k v x) (f' k v x)"
shows "
flat_ge (it' s (case_dres False False c) (λ(k,v) s. s ⤜ f k v) σ)
(it' s (case_dres False False c) (λ(k,v) s. s ⤜ f' k v) σ)"
(is "flat_ge ?a ?b")
proof -
from proper_itE[OF PR[THEN proper_it'D]] obtain l where
A_FMT:
"?a = foldli l (case_dres False False c) (λ(k,v) s. s ⤜ f k v) σ"
(is "_ = ?a'")
and B_FMT:
"?b = foldli l (case_dres False False c) (λ(k,v) s. s ⤜ f' k v) σ"
(is "_ = ?b'")
by metis
from A have A': "⋀kv x. flat_ge (case_prod f kv x) (case_prod f' kv x)"
by auto
note A_FMT
also have
"?a' = foldli l (case_dres False False c) (λkv s. s ⤜ case_prod f kv) σ"
apply (fo_rule fun_cong)
apply (fo_rule arg_cong)
by auto
also note foldli_mono_dres_flat[OF A']
also have
"foldli l (case_dres False False c) (λkv s. s ⤜ case_prod f' kv) σ = ?b'"
apply (fo_rule fun_cong)
apply (fo_rule arg_cong)
by auto
also note B_FMT[symmetric]
finally show ?thesis .
qed
lemma proper_it_mono_dres:
assumes PR: "proper_it' it it'"
assumes A: "⋀kv x. f kv x ≤ f' kv x"
shows "
it' s (case_dres False False c) (λkv s. s ⤜ f kv) σ
≤ it' s (case_dres False False c) (λkv s. s ⤜ f' kv) σ"
apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
apply (erule_tac t="it' s" in ssubst)
apply (rule foldli_mono_dres[OF A])
done
lemma proper_it_mono_dres_flat:
assumes PR: "proper_it' it it'"
assumes A: "⋀kv x. flat_ge (f kv x) (f' kv x)"
shows "
flat_ge (it' s (case_dres False False c) (λkv s. s ⤜ f kv) σ)
(it' s (case_dres False False c) (λkv s. s ⤜ f' kv) σ)"
apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
apply (erule_tac t="it' s" in ssubst)
apply (rule foldli_mono_dres_flat[OF A])
done
lemma pi'_dom[icf_proper_iteratorI]: "proper_it' it it'
⟹ proper_it' (map_iterator_dom o it) (map_iterator_dom o it')"
apply (rule proper_it'I)
apply (simp add: comp_def)
apply (rule icf_proper_iteratorI)
apply (erule proper_it'D)
done
lemma proper_it_mono_dres_dom:
assumes PR: "proper_it' it it'"
assumes A: "⋀kv x. f kv x ≤ f' kv x"
shows "
(map_iterator_dom o it') s (case_dres False False c) (λkv s. s ⤜ f kv) σ
≤
(map_iterator_dom o it') s (case_dres False False c) (λkv s. s ⤜ f' kv) σ"
apply (rule proper_it_mono_dres)
apply (rule icf_proper_iteratorI)
by fact+
lemma proper_it_mono_dres_dom_flat:
assumes PR: "proper_it' it it'"
assumes A: "⋀kv x. flat_ge (f kv x) (f' kv x)"
shows "flat_ge
((map_iterator_dom o it') s (case_dres False False c) (λkv s. s ⤜ f kv) σ)
((map_iterator_dom o it') s (case_dres False False c) (λkv s. s ⤜ f' kv) σ)"
apply (rule proper_it_mono_dres_flat)
apply (rule icf_proper_iteratorI)
by fact+
lemmas proper_it_monos =
proper_it_mono_dres_pair proper_it_mono_dres_pair_flat
proper_it_mono_dres proper_it_mono_dres_flat
proper_it_mono_dres_dom proper_it_mono_dres_dom_flat
attribute_setup "proper_it" = ‹
Scan.succeed (Thm.declaration_attribute (fn thm => fn context =>
let
val mono_thms = map_filter (try (curry (RS) thm)) @{thms proper_it_monos}
val context = context
|> Icf_Proper_Iterator.add_thm thm
|> fold Refine_Mono_Prover.add_mono_thm mono_thms
in
context
end
))
›
"Proper iterator declaration"
end
Theory Idx_Iterator
section ‹\isaheader{Iterator by get and size }›
theory Idx_Iterator
imports
SetIterator
Automatic_Refinement.Automatic_Refinement
begin
fun idx_iteratei_aux
:: "('s ⇒ nat ⇒ 'a) ⇒ nat ⇒ nat ⇒ 's ⇒ ('σ⇒bool) ⇒ ('a ⇒'σ ⇒ 'σ) ⇒ 'σ ⇒ 'σ"
where
"idx_iteratei_aux get sz i l c f σ = (
if i=0 ∨ ¬ c σ then σ
else idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) σ)
)"
declare idx_iteratei_aux.simps[simp del]
lemma idx_iteratei_aux_simps[simp]:
"i=0 ⟹ idx_iteratei_aux get sz i l c f σ = σ"
"¬c σ ⟹ idx_iteratei_aux get sz i l c f σ = σ"
"⟦i≠0; c σ⟧ ⟹ idx_iteratei_aux get sz i l c f σ = idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) σ)"
apply -
apply (subst idx_iteratei_aux.simps, simp)+
done
definition "idx_iteratei get sz l c f σ == idx_iteratei_aux get (sz l) (sz l) l c f σ"
lemma idx_iteratei_eq_foldli:
assumes sz: "(sz, length) ∈ arel → nat_rel"
assumes get: "(get, (!)) ∈ arel → nat_rel → Id"
assumes "(s,s') ∈ arel"
shows "(idx_iteratei get sz s, foldli s') ∈ Id"
proof-
have size_correct: "⋀s s'. (s,s') ∈ arel ⟹ sz s = length s'"
using sz[param_fo] by simp
have get_correct: "⋀s s' n. (s,s') ∈ arel ⟹ get s n = s' ! n"
using get[param_fo] by simp
{
fix n l
assume A: "Suc n ≤ length l"
hence B: "length l - Suc n < length l" by simp
from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
from Cons_nth_drop_Suc[OF B, simplified] have
"drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l"
by simp
} note drop_aux=this
{
fix s s' c f σ i
assume "(s,s') ∈ arel" "i≤sz s"
hence "idx_iteratei_aux get (sz s) i s c f σ = foldli (drop (sz s - i) s') c f σ"
proof (induct i arbitrary: σ)
case 0 with size_correct[of s] show ?case by simp
next
case (Suc n)
note S = Suc.prems(1)
show ?case proof (cases "c σ")
case False thus ?thesis by simp
next
case [simp, intro!]: True
show ?thesis using Suc
by (simp add: size_correct[OF S] get_correct[OF S] drop_aux)
qed
qed
} note aux=this
show ?thesis
unfolding idx_iteratei_def[abs_def]
by (simp, intro ext, simp add: aux[OF ‹(s,s') ∈ arel›])
qed
text ‹Misc.›
lemma idx_iteratei_aux_nth_conv_foldli_drop:
fixes xs :: "'b list"
assumes "i ≤ length xs"
shows "idx_iteratei_aux (!) (length xs) i xs c f σ = foldli (drop (length xs - i) xs) c f σ"
using assms
proof(induct get≡"(!) :: 'b list ⇒ nat ⇒ 'b" sz≡"length xs" i xs c f σ rule: idx_iteratei_aux.induct)
case (1 i l c f σ)
show ?case
proof(cases "i = 0 ∨ ¬ c σ")
case True thus ?thesis
by(subst idx_iteratei_aux.simps)(auto)
next
case False
hence i: "i > 0" and c: "c σ" by auto
hence "idx_iteratei_aux (!) (length l) i l c f σ = idx_iteratei_aux (!) (length l) (i - 1) l c f (f (l ! (length l - i)) σ)"
by(subst idx_iteratei_aux.simps) simp
also have "… = foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) σ)"
using ‹i ≤ length l› i c by -(rule 1, auto)
also from ‹i ≤ length l› i
have "drop (length l - i) l = (l ! (length l - i)) # drop (length l - (i - 1)) l"
apply (subst Cons_nth_drop_Suc[symmetric])
apply simp_all
done
hence "foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) σ) = foldli (drop (length l - i) l) c f σ"
using c by simp
finally show ?thesis .
qed
qed
lemma idx_iteratei_nth_length_conv_foldli: "idx_iteratei nth length = foldli"
by(rule ext)+(simp add: idx_iteratei_def idx_iteratei_aux_nth_conv_foldli_drop)
end
Theory Iterator
theory Iterator
imports
It_to_It
SetIteratorOperations
SetIteratorGA
Proper_Iterator
Gen_Iterator
Idx_Iterator
begin
text ‹Folding over a list created by a proper iterator can be replaced
by a single iteration›
lemma proper_it_to_list_opt[refine_transfer_post_subst]:
assumes PR: "proper_it' it it'"
shows "foldli o it_to_list it ≡ it'"
proof (rule eq_reflection, intro ext)
fix s c f σ
obtain l where "it s = foldli l" and "it' s = foldli l"
by (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
thus "(foldli o it_to_list it) s c f σ = it' s c f σ"
by (simp add: comp_def it_to_list_def)
qed
lemma iterator_cnv_to_comp[refine_transfer_post_simp]:
"foldli (it_to_list it x) = (foldli o it_to_list it) x"
by auto
declare idx_iteratei_eq_foldli[autoref_rules]
end
Theory RBT_add
section ‹\isaheader{Additions to RB-Trees}›
theory RBT_add
imports
"HOL-Library.RBT_Impl"
"../Iterator/Iterator"
begin
text_raw ‹\label{thy:RBT_add}›
lemma tlt_trans: "⟦l |« u; u≤v⟧ ⟹ l |« v"
by (induct l) auto
lemma trt_trans: "⟦ u≤v; v«|r ⟧ ⟹ u«|r"
by (induct r) auto
lemmas tlt_trans' = tlt_trans[OF _ less_imp_le]
lemmas trt_trans' = trt_trans[OF less_imp_le]
primrec rm_iterateoi
:: "('k,'v) RBT_Impl.rbt ⇒ ('k × 'v, 'σ) set_iterator"
where
"rm_iterateoi RBT_Impl.Empty c f σ = σ" |
"rm_iterateoi (RBT_Impl.Branch col l k v r) c f σ = (
if (c σ) then
let σ' = rm_iterateoi l c f σ in
if (c σ') then
rm_iterateoi r c f (f (k, v) σ')
else σ'
else
σ
)"
lemma rm_iterateoi_abort :
"¬(c σ) ⟹ rm_iterateoi t c f σ = σ"
by (cases t) auto
lemma rm_iterateoi_alt_def :
"rm_iterateoi RBT_Impl.Empty = set_iterator_emp"
"rm_iterateoi (RBT_Impl.Branch col l k v r) =
set_iterator_union (rm_iterateoi l)
(set_iterator_union (set_iterator_sng (k, v)) (rm_iterateoi r))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_iterateoi_abort
set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_iterateoi.simps[simp del]
primrec rm_reverse_iterateoi
:: "('k,'v) RBT_Impl.rbt ⇒ ('k × 'v, 'σ) set_iterator"
where
"rm_reverse_iterateoi RBT_Impl.Empty c f σ = σ" |
"rm_reverse_iterateoi (Branch col l k v r) c f σ = (
if (c σ) then
let σ' = rm_reverse_iterateoi r c f σ in
if (c σ') then
rm_reverse_iterateoi l c f (f (k, v) σ')
else σ'
else
σ
)"
lemma rm_reverse_iterateoi_abort :
"¬(c σ) ⟹ rm_reverse_iterateoi t c f σ = σ"
by (cases t) auto
lemma rm_reverse_iterateoi_alt_def :
"rm_reverse_iterateoi RBT_Impl.Empty = set_iterator_emp"
"rm_reverse_iterateoi (RBT_Impl.Branch col l k v r) =
set_iterator_union (rm_reverse_iterateoi r)
(set_iterator_union (set_iterator_sng (k, v)) (rm_reverse_iterateoi l))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_reverse_iterateoi_abort
set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_reverse_iterateoi.simps[simp del]
lemma (in linorder) map_to_set_lookup_entries:
"rbt_sorted t ⟹ map_to_set (rbt_lookup t) = set (RBT_Impl.entries t)"
using map_of_entries[symmetric,of t]
by (simp add: distinct_entries map_to_set_map_of)
lemma (in linorder) rm_iterateoi_correct:
fixes t::"('a, 'v) RBT_Impl.rbt"
assumes is_sort: "rbt_sorted t"
defines "it ≡
RBT_add.rm_iterateoi::(('a, 'v) RBT_Impl.rbt ⇒ ('a × 'v, 'σ) set_iterator)"
shows "map_iterator_linord (it t) (rbt_lookup t)"
using is_sort
proof (induct t)
case Empty
show ?case unfolding it_def
by (simp add: rm_iterateoi_alt_def
map_iterator_linord_emp_correct rbt_lookup_Empty)
next
case (Branch c l k v r)
note is_sort_t = Branch(3)
from Branch(1) is_sort_t have
l_it: "map_iterator_linord (it l) (rbt_lookup l)" by simp
from Branch(2) is_sort_t have
r_it: "map_iterator_linord (it r) (rbt_lookup r)" by simp
note kv_it = map_iterator_linord_sng_correct[of k v]
have kv_r_it : "set_iterator_map_linord
(set_iterator_union (set_iterator_sng (k, v)) (it r))
(map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup r))"
proof (rule map_iterator_linord_union_correct [OF kv_it r_it])
fix kv kv'
assume pre: "kv ∈ map_to_set [k ↦ v]" "kv' ∈ map_to_set (rbt_lookup r)"
obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule prod.exhaust)
from pre is_sort_t show "fst kv < fst kv'"
apply (simp add: map_to_set_lookup_entries split: prod.splits)
apply (metis entry_in_tree_keys rbt_greater_prop)
done
qed
have l_kv_r_it : "set_iterator_map_linord (it (Branch c l k v r))
(map_to_set (rbt_lookup l)
∪ (map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup r)))"
unfolding it_def rm_iterateoi_alt_def
unfolding it_def[symmetric]
proof (rule map_iterator_linord_union_correct [OF l_it kv_r_it])
fix kv1 kv2
assume pre: "kv1 ∈ map_to_set (rbt_lookup l)"
"kv2 ∈ map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup r)"
obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule prod.exhaust)
obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule prod.exhaust)
from pre is_sort_t show "fst kv1 < fst kv2"
apply (simp add: map_to_set_lookup_entries split: prod.splits)
by (metis (lifting) map_of_entries neqE option.simps(3)
ord.rbt_lookup_rbt_greater ord.rbt_lookup_rbt_less rbt_greater_trans
rbt_less_trans weak_map_of_SomeI)
qed
from is_sort_t
have map_eq: "map_to_set (rbt_lookup l)
∪ (map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup r)) =
map_to_set (rbt_lookup (Branch c l k v r))"
by (simp add: set_eq_iff map_to_set_lookup_entries)
from l_kv_r_it[unfolded map_eq]
show ?case .
qed
lemma (in linorder) rm_reverse_iterateoi_correct:
fixes t::"('a, 'v) RBT_Impl.rbt"
assumes is_sort: "rbt_sorted t"
defines "it ≡ RBT_add.rm_reverse_iterateoi
::(('a, 'v) RBT_Impl.rbt ⇒ ('a × 'v, 'σ) set_iterator)"
shows "map_iterator_rev_linord (it t) (rbt_lookup t)"
using is_sort
proof (induct t)
case Empty
show ?case unfolding it_def
by (simp add: rm_reverse_iterateoi_alt_def
map_iterator_rev_linord_emp_correct rbt_lookup_Empty)
next
case (Branch c l k v r)
note is_sort_t = Branch(3)
from Branch(1) is_sort_t have
l_it: "map_iterator_rev_linord (it l) (rbt_lookup l)" by simp
from Branch(2) is_sort_t have
r_it: "map_iterator_rev_linord (it r) (rbt_lookup r)" by simp
note kv_it = map_iterator_rev_linord_sng_correct[of k v]
have kv_l_it : "set_iterator_map_rev_linord
(set_iterator_union (set_iterator_sng (k, v)) (it l))
(map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup l))"
proof (rule map_iterator_rev_linord_union_correct [OF kv_it l_it])
fix kv kv'
assume pre: "kv ∈ map_to_set [k ↦ v]" "kv' ∈ map_to_set (rbt_lookup l)"
obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule prod.exhaust)
from pre is_sort_t show "fst kv > fst kv'"
apply (simp add: map_to_set_lookup_entries split: prod.splits)
apply (metis entry_in_tree_keys rbt_less_prop)
done
qed
have r_kv_l_it : "set_iterator_map_rev_linord (it (Branch c l k v r))
(map_to_set (rbt_lookup r)
∪ (map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup l)))"
unfolding it_def rm_reverse_iterateoi_alt_def
unfolding it_def[symmetric]
proof (rule map_iterator_rev_linord_union_correct [OF r_it kv_l_it])
fix kv1 kv2
assume pre: "kv1 ∈ map_to_set (rbt_lookup r)"
"kv2 ∈ map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup l)"
obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule prod.exhaust)
obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule prod.exhaust)
from pre is_sort_t show "fst kv1 > fst kv2"
apply (simp add: map_to_set_lookup_entries split: prod.splits)
by (metis (mono_tags) entry_in_tree_keys neq_iff option.simps(3)
ord.rbt_greater_prop ord.rbt_lookup_rbt_less rbt_less_trans
rbt_lookup_in_tree)
qed
from is_sort_t
have map_eq: "map_to_set (rbt_lookup r)
∪ (map_to_set [k ↦ v] ∪ map_to_set (rbt_lookup l)) =
map_to_set (rbt_lookup (Branch c l k v r))"
by (auto simp add: set_eq_iff map_to_set_lookup_entries)
from r_kv_l_it[unfolded map_eq]
show ?case .
qed
lemma pi_rm[icf_proper_iteratorI]:
"proper_it (RBT_add.rm_iterateoi t) (RBT_add.rm_iterateoi t)"
by (induct t) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)
lemma pi_rm_rev[icf_proper_iteratorI]:
"proper_it (RBT_add.rm_reverse_iterateoi t) (RBT_add.rm_reverse_iterateoi t)"
by (induct t) (simp_all add: rm_reverse_iterateoi_alt_def
icf_proper_iteratorI)
primrec bheight_aux :: "('a,'b) RBT_Impl.rbt ⇒ nat ⇒ nat"
where
"⋀acc. bheight_aux RBT_Impl.Empty acc = acc"
| "⋀acc. bheight_aux (RBT_Impl.Branch c lt k v rt) acc =
bheight_aux lt (case c of RBT_Impl.B ⇒ Suc acc | RBT_Impl.R ⇒ acc)"
lemma bheight_aux_eq: "bheight_aux t a = bheight t + a"
by (induct t arbitrary: a) (auto split: RBT_Impl.color.split)
definition [code_unfold]: "rbt_bheight t ≡ bheight_aux t 0"
lemma "rbt_bheight t = bheight t"
unfolding rbt_bheight_def by (simp add: bheight_aux_eq)
end
Theory Dlist_add
section ‹\isaheader{Additions to Distinct Lists}›
theory Dlist_add
imports
"HOL-Library.Dlist"
Automatic_Refinement.Misc
"../Iterator/SetIteratorOperations"
begin
primrec dlist_remove1' :: "'a ⇒ 'a list ⇒ 'a list ⇒ 'a list"
where
"dlist_remove1' x z [] = z"
| "dlist_remove1' x z (y # ys)
= (if x = y then z @ ys else dlist_remove1' x (y # z) ys)"
definition dlist_remove' :: "'a ⇒ 'a dlist ⇒ 'a dlist"
where "dlist_remove' a xs = Dlist (dlist_remove1' a [] (list_of_dlist xs))"
lemma distinct_remove1': "distinct (xs @ ys) ⟹
distinct (dlist_remove1' x xs ys)"
by(induct ys arbitrary: xs) simp_all
lemma set_dlist_remove1': "distinct ys ⟹
set (dlist_remove1' x xs ys) = set xs ∪ (set ys - {x})"
by(induct ys arbitrary: xs) auto
lemma list_of_dlist_remove' [simp, code abstract]:
"list_of_dlist (dlist_remove' a xs) = dlist_remove1' a [] (list_of_dlist xs)"
by(simp add: dlist_remove'_def distinct_remove1')
lemma dlist_remove'_correct:
"y ∈ set (list_of_dlist (dlist_remove' x xs))
⟷ (if x = y then False else y ∈ set (list_of_dlist xs))"
by(simp add: dlist_remove'_def
Dlist.member_def List.member_def set_dlist_remove1')
definition dlist_iteratei :: "'a dlist ⇒ ('a, 'b) set_iterator"
where "dlist_iteratei xs = foldli (list_of_dlist xs)"
lemma dlist_iteratei_correct:
"set_iterator (dlist_iteratei xs) (set (list_of_dlist xs))"
using distinct_list_of_dlist[of xs]
set_iterator_foldli_correct[of "list_of_dlist xs"]
unfolding Dlist.member_def List.member_def dlist_iteratei_def
by simp
lemma dlist_member_empty: "(set (list_of_dlist Dlist.empty)) = {}"
by(simp add: Dlist.empty_def)
lemma dlist_member_insert [simp]: "set (list_of_dlist (Dlist.insert x xs))
= insert x (set (list_of_dlist xs))"
by(simp add: Dlist.insert_def Dlist.member_def )
lemma dlist_finite_member [simp, intro!]: "finite (set (list_of_dlist xs))"
by(simp add: member_def )
end
Theory Assoc_List
section ‹\isaheader{The type of associative lists}›
theory Assoc_List
imports
"HOL-Library.AList"
"../Iterator/SetIteratorOperations"
begin
subsection ‹Type ‹('a, 'b) assoc_list››
typedef ('k, 'v) assoc_list = "{xs :: ('k × 'v) list. distinct (map fst xs)}"
morphisms impl_of Assoc_List
by(rule exI[where x="[]"]) simp
lemma assoc_list_ext: "impl_of xs = impl_of ys ⟹ xs = ys"
by(simp add: impl_of_inject)
lemma expand_assoc_list_eq: "xs = ys ⟷ impl_of xs = impl_of ys"
by(simp add: impl_of_inject)
lemma impl_of_distinct [simp, intro]: "distinct (map fst (impl_of al))"
using impl_of[of al] by simp
lemma impl_of_distinct_full [simp, intro]: "distinct (impl_of al)"
using impl_of_distinct[of al]
unfolding distinct_map by simp
lemma Assoc_List_impl_of [code abstype]: "Assoc_List (impl_of al) = al"
by(rule impl_of_inverse)
subsection ‹Primitive operations›
definition empty :: "('k, 'v) assoc_list"
where [code del]: "empty = Assoc_List []"
definition lookup :: "('k, 'v) assoc_list ⇒ 'k ⇒ 'v option"
where [code]: "lookup al = map_of (impl_of al)"
definition update_with :: "'v ⇒ 'k ⇒ ('v ⇒ 'v) ⇒ ('k, 'v) assoc_list ⇒ ('k, 'v) assoc_list"
where [code del]: "update_with v k f al = Assoc_List (AList.update_with_aux v k f (impl_of al))"
definition delete :: "'k ⇒ ('k, 'v) assoc_list ⇒ ('k, 'v) assoc_list"
where [code del]: "delete k al = Assoc_List (AList.delete_aux k (impl_of al))"
definition iteratei :: "('k, 'v) assoc_list ⇒ ('s⇒bool) ⇒ ('k × 'v ⇒ 's ⇒ 's) ⇒ 's ⇒ 's"
where [code]: "iteratei al c f = foldli (impl_of al) c f"
lemma impl_of_empty [code abstract]: "impl_of empty = []"
by(simp add: empty_def Assoc_List_inverse)
lemma impl_of_update_with [code abstract]:
"impl_of (update_with v k f al) = AList.update_with_aux v k f (impl_of al)"
by(simp add: update_with_def Assoc_List_inverse)
lemma impl_of_delete [code abstract]:
"impl_of (delete k al) = AList.delete_aux k (impl_of al)"
by(simp add: delete_def Assoc_List_inverse)
subsection ‹Abstract operation properties›
lemma lookup_empty [simp]: "lookup empty k = None"
by(simp add: empty_def lookup_def Assoc_List_inverse)
lemma lookup_empty': "lookup empty = Map.empty"
by(rule ext) simp
lemma lookup_update_with [simp]:
"lookup (update_with v k f al) = (lookup al)(k ↦ case lookup al k of None ⇒ f v | Some v ⇒ f v)"
by(simp add: lookup_def update_with_def Assoc_List_inverse map_of_update_with_aux)
lemma lookup_delete [simp]: "lookup (delete k al) = (lookup al)(k := None)"
by(simp add: lookup_def delete_def Assoc_List_inverse distinct_delete map_of_delete_aux')
lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup m))"
by(simp add: lookup_def finite_dom_map_of)
lemma iteratei_correct:
"map_iterator (iteratei m) (lookup m)"
unfolding iteratei_def[abs_def] lookup_def map_to_set_def
by (simp add: set_iterator_foldli_correct)
subsection ‹Derived operations›
definition update :: "'key ⇒ 'val ⇒ ('key, 'val) assoc_list ⇒ ('key, 'val) assoc_list"
where "update k v = update_with v k (λ_. v)"
definition set :: "('key, 'val) assoc_list ⇒ ('key × 'val) set"
where "set al = List.set (impl_of al)"
lemma lookup_update [simp]: "lookup (update k v al) = (lookup al)(k ↦ v)"
by(simp add: update_def split: option.split)
lemma set_empty [simp]: "set empty = {}"
by(simp add: set_def empty_def Assoc_List_inverse)
lemma set_update_with:
"set (update_with v k f al) =
(set al - {k} × UNIV ∪ {(k, f (case lookup al k of None ⇒ v | Some v ⇒ v))})"
by(simp add: set_def update_with_def Assoc_List_inverse set_update_with_aux lookup_def)
lemma set_update: "set (update k v al) = (set al - {k} × UNIV ∪ {(k, v)})"
by(simp add: update_def set_update_with)
lemma set_delete: "set (delete k al) = set al - {k} × UNIV"
by(simp add: set_def delete_def Assoc_List_inverse set_delete_aux)
subsection ‹Type classes›
instantiation assoc_list :: (equal, equal) equal begin
definition "equal_class.equal (al :: ('a, 'b) assoc_list) al' == impl_of al = impl_of al'"
instance
proof
qed (simp add: equal_assoc_list_def impl_of_inject)
end
instantiation assoc_list :: (type, type) size begin
definition "size (al :: ('a, 'b) assoc_list) = length (impl_of al)"
instance ..
end
hide_const (open) impl_of empty lookup update_with set update delete iteratei
subsection ‹@{const map_ran}›
text ‹@{term map_ran} with more general type - lemmas replicated from AList in HOL/Library›
hide_const (open) map_ran
primrec
map_ran :: "('key ⇒ 'val ⇒ 'val') ⇒ ('key × 'val) list ⇒ ('key × 'val') list"
where
"map_ran f [] = []"
| "map_ran f (p#ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"
lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
by (induct al) auto
lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
by (induct al) auto
lemma distinct_map_ran: "distinct (map fst al) ⟹ distinct (map fst (map_ran f al))"
by (induct al) (auto simp add: dom_map_ran)
lemma map_ran_filter: "map_ran f [(a, _)←ps. fst p ≠ a] = [(a, _)←map_ran f ps. fst p ≠ a]"
by (induct ps) auto
lemma clearjunk_map_ran: "AList.clearjunk (map_ran f al)
= map_ran f (AList.clearjunk al)"
by (induct al rule: clearjunk.induct) (simp_all add: AList.delete_eq map_ran_filter)
text ‹new lemmas and definitions›
lemma map_ran_cong [fundef_cong]:
"⟦ al = al'; ⋀k v. (k, v) ∈ set al ⟹ f k v = g k v ⟧ ⟹ map_ran f al = map_ran g al'"
by hypsubst_thin (induct al', auto)
lemma size_list_delete: "size_list f (AList.delete a al) ≤ size_list f al"
by(induct al) simp_all
lemma size_list_clearjunk: "size_list f (AList.clearjunk al) ≤ size_list f al"
by(induct al)(auto simp add: clearjunk_delete intro: le_trans[OF size_list_delete])
lemma set_delete_conv: "set (AList.delete a al) = set al - ({a} × UNIV)"
proof(induct al)
case (Cons kv al)
thus ?case by(cases kv) auto
qed simp
lemma set_clearjunk_subset: "set (AList.clearjunk al) ⊆ set al"
by(induct al)(auto simp add: clearjunk_delete set_delete_conv)
lemma map_ran_conv_map:
"map_ran f xs = map (λ(k, v). (k, f k v)) xs"
by(induct xs) auto
lemma card_dom_map_of: "distinct (map fst al) ⟹ card (dom (map_of al)) = length al"
by(induct al)(auto simp add: card_insert_if finite_dom_map_of dom_map_of_conv_image_fst)
lemma map_of_map_inj_fst:
assumes "inj f"
shows "map_of (map (λ(k, v). (f k, v)) xs) (f x) = map_of xs x"
by(induct xs)(auto dest: injD[OF ‹inj f›])
lemma length_map_ran [simp]: "length (map_ran f xs) = length xs"
by(induct xs) simp_all
lemma length_update:
"length (AList.update k v xs)
= (if k ∈ fst ` set xs then length xs else Suc (length xs))"
by(induct xs) simp_all
lemma length_distinct:
"distinct (map fst xs) ⟹ length (AList.delete k xs)
= (if k ∈ fst ` set xs then length xs - 1 else length xs)"
by(induct xs)(auto split: if_split_asm simp add: in_set_conv_nth)
lemma finite_Assoc_List_set_image:
assumes "finite (Assoc_List.set ` A)"
shows "finite A"
proof -
have "Assoc_List.set ` A = set ` Assoc_List.impl_of ` A"
by (auto simp add: Assoc_List.set_def)
with assms finite_set_image have "finite (Assoc_List.impl_of ` A)" by auto
with assoc_list_ext show ?thesis by (metis inj_onI finite_imageD)
qed
end
Theory Diff_Array
section ‹Arrays with in-place updates›
theory Diff_Array imports
Assoc_List
Automatic_Refinement.Parametricity
"HOL-Library.Code_Target_Numeral"
begin
datatype 'a array = Array "'a list"
subsection ‹primitive operations›
definition new_array :: "'a ⇒ nat ⇒ 'a array"
where "new_array a n = Array (replicate n a)"
primrec array_length :: "'a array ⇒ nat"
where "array_length (Array a) = length a"
primrec array_get :: "'a array ⇒ nat ⇒ 'a"
where "array_get (Array a) n = a ! n"
primrec array_set :: "'a array ⇒ nat ⇒ 'a ⇒ 'a array"
where "array_set (Array A) n a = Array (A[n := a])"
definition array_of_list :: "'a list ⇒ 'a array"
where "array_of_list = Array"
primrec array_grow :: "'a array ⇒ nat ⇒ 'a ⇒ 'a array"
where "array_grow (Array A) inc x = Array (A @ replicate inc x)"
primrec array_shrink :: "'a array ⇒ nat ⇒ 'a array"
where "array_shrink (Array A) sz = (
if (sz > length A) then
undefined
else
Array (take sz A)
)"
subsection ‹Derived operations›
text ‹The following operations are total versions of
‹array_get› and ‹array_set›, which return a default
value in case the index is out of bounds.
They can be efficiently implemented in the target language by catching
exceptions.
›
definition "array_get_oo x a i ≡
if i<array_length a then array_get a i else x"
definition "array_set_oo f a i v ≡
if i<array_length a then array_set a i v else f ()"
primrec list_of_array :: "'a array ⇒ 'a list"
where "list_of_array (Array a) = a"
primrec assoc_list_of_array :: "'a array ⇒ (nat × 'a) list"
where "assoc_list_of_array (Array a) = zip [0..<length a] a"
function assoc_list_of_array_code :: "'a array ⇒ nat ⇒ (nat × 'a) list"
where [simp del]:
"assoc_list_of_array_code a n =
(if array_length a ≤ n then []
else (n, array_get a n) # assoc_list_of_array_code a (n + 1))"
by pat_completeness auto
termination assoc_list_of_array_code
by(relation "measure (λp. (array_length (fst p) - snd p))") auto
definition array_map :: "(nat ⇒ 'a ⇒ 'b) ⇒ 'a array ⇒ 'b array"
where "array_map f a = array_of_list (map (λ(i, v). f i v) (assoc_list_of_array a))"
definition array_foldr :: "(nat ⇒ 'a ⇒ 'b ⇒ 'b) ⇒ 'a array ⇒ 'b ⇒ 'b"
where "array_foldr f a b = foldr (λ(k, v). f k v) (assoc_list_of_array a) b"
definition array_foldl :: "(nat ⇒ 'b ⇒ 'a ⇒ 'b) ⇒ 'b ⇒ 'a array ⇒ 'b"
where "array_foldl f b a = foldl (λb (k, v). f k b v) b (assoc_list_of_array a)"
subsection ‹Lemmas›
lemma array_length_new_array [simp]:
"array_length (new_array a n) = n"
by(simp add: new_array_def)
lemma array_length_array_set [simp]:
"array_length (array_set a i e) = array_length a"
by(cases a) simp
lemma array_get_new_array [simp]:
"i < n ⟹ array_get (new_array a n) i = a"
by(simp add: new_array_def)
lemma array_get_array_set_same [simp]:
"n < array_length A ⟹ array_get (array_set A n a) n = a"
by(cases A) simp
lemma array_get_array_set_other:
"n ≠ n' ⟹ array_get (array_set A n a) n' = array_get A n'"
by(cases A) simp
lemma list_of_array_grow [simp]:
"list_of_array (array_grow a inc x) = list_of_array a @ replicate inc x"
by (cases a) (simp)
lemma array_grow_length [simp]:
"array_length (array_grow a inc x) = array_length a + inc"
by (cases a)(simp add: array_of_list_def)
lemma array_grow_get [simp]:
"i < array_length a ⟹ array_get (array_grow a inc x) i = array_get a i"
"⟦ i ≥ array_length a; i < array_length a + inc⟧ ⟹ array_get (array_grow a inc x) i = x"
by (cases a, simp add: nth_append)+
lemma list_of_array_shrink [simp]:
"⟦ s ≤ array_length a⟧ ⟹ list_of_array (array_shrink a s) = take s (list_of_array a)"
by (cases a) simp
lemma array_shrink_get [simp]:
"⟦ i < s; s ≤ array_length a ⟧ ⟹ array_get (array_shrink a s) i = array_get a i"
by (cases a) (simp)
lemma list_of_array_id [simp]: "list_of_array (array_of_list l) = l"
by (cases l)(simp_all add: array_of_list_def)
lemma map_of_assoc_list_of_array:
"map_of (assoc_list_of_array a) k = (if k < array_length a then Some (array_get a k) else None)"
by(cases a, cases "k < array_length a")(force simp add: set_zip)+
lemma length_assoc_list_of_array [simp]:
"length (assoc_list_of_array a) = array_length a"
by(cases a) simp
lemma distinct_assoc_list_of_array:
"distinct (map fst (assoc_list_of_array a))"
by(cases a)(auto)
lemma array_length_array_map [simp]:
"array_length (array_map f a) = array_length a"
by(simp add: array_map_def array_of_list_def)
lemma array_get_array_map [simp]:
"i < array_length a ⟹ array_get (array_map f a) i = f i (array_get a i)"
by(cases a)(simp add: array_map_def map_ran_conv_map array_of_list_def)
lemma array_foldr_foldr:
"array_foldr (λn. f) (Array a) b = foldr f a b"
by(simp add: array_foldr_def foldr_snd_zip)
lemma assoc_list_of_array_code_induct:
assumes IH: "⋀n. (n < array_length a ⟹ P (Suc n)) ⟹ P n"
shows "P n"
proof -
have "a = a ⟶ P n"
by(rule assoc_list_of_array_code.induct[where P="λa' n. a = a' ⟶ P n"])(auto intro: IH)
thus ?thesis by simp
qed
lemma assoc_list_of_array_code [code]:
"assoc_list_of_array a = assoc_list_of_array_code a 0"
proof(cases a)
case (Array A)
{ fix n
have "zip [n..<length A] (drop n A) = assoc_list_of_array_code (Array A) n"
proof(induct n taking: "Array A" rule: assoc_list_of_array_code_induct)
case (1 n)
show ?case
proof(cases "n < array_length (Array A)")
case False
thus ?thesis by(simp add: assoc_list_of_array_code.simps)
next
case True
hence "zip [Suc n..<length A] (drop (Suc n) A) = assoc_list_of_array_code (Array A) (Suc n)"
by(rule 1)
moreover from True have "n < length A" by simp
moreover then obtain a A' where A: "drop n A = a # A'" by(cases "drop n A") auto
moreover with ‹n < length A› have [simp]: "a = A ! n"
by(subst append_take_drop_id[symmetric, where n=n])(simp add: nth_append min_def)
moreover from A have "drop (Suc n) A = A'"
by(induct A arbitrary: n)(simp_all add: drop_Cons split: nat.split_asm)
ultimately show ?thesis by(subst upt_rec)(simp add: assoc_list_of_array_code.simps)
qed
qed }
note this[of 0]
with Array show ?thesis by simp
qed
lemma list_of_array_code [code]:
"list_of_array a = array_foldr (λn. Cons) a []"
by(cases a)(simp add: array_foldr_foldr foldr_Cons)
lemma array_foldr_cong [fundef_cong]:
"⟦ a = a'; b = b';
⋀i b. i < array_length a ⟹ f i (array_get a i) b = g i (array_get a i) b ⟧
⟹ array_foldr f a b = array_foldr g a' b'"
by(cases a)(auto simp add: array_foldr_def set_zip intro!: foldr_cong)
lemma array_foldl_foldl:
"array_foldl (λn. f) b (Array a) = foldl f b a"
by(simp add: array_foldl_def foldl_snd_zip)
lemma array_map_conv_foldl_array_set:
assumes len: "array_length A = array_length a"
shows "array_map f a = foldl (λA (k, v). array_set A k (f k v)) A (assoc_list_of_array a)"
proof(cases a)
case (Array xs)
obtain ys where [simp]: "A = Array ys" by(cases A)
with Array len have "length xs ≤ length ys" by simp
hence "foldr (λx y. array_set y (fst x) (f (fst x) (snd x)))
(rev (zip [0..<length xs] xs)) (Array ys) =
Array (map (λx. f (fst x) (snd x)) (zip [0..<length xs] xs) @ drop (length xs) ys)"
proof(induct xs arbitrary: ys rule: rev_induct)
case Nil thus ?case by simp
next
case (snoc x xs ys)
from ‹length (xs @ [x]) ≤ length ys› have "length xs ≤ length ys" by simp
hence "foldr (λx y. array_set y (fst x) (f (fst x) (snd x)))
(rev (zip [0..<length xs] xs)) (Array ys) =
Array (map (λx. f (fst x) (snd x)) (zip [0..<length xs] xs) @ drop (length xs) ys)"
by(rule snoc)
moreover from ‹length (xs @ [x]) ≤ length ys›
obtain y ys' where ys: "drop (length xs) ys = y # ys'"
by(cases "drop (length xs) ys") auto
moreover hence "drop (Suc (length xs)) ys = ys'" by(auto dest: drop_eq_ConsD)
ultimately show ?case by(simp add: list_update_append)
qed
thus ?thesis using Array len
by(simp add: array_map_def split_beta array_of_list_def foldl_conv_foldr)
qed
subsection ‹Lemmas about empty arrays›
lemma array_length_eq_0 [simp]:
"array_length a = 0 ⟷ a = Array []"
by(cases a) simp
lemma new_array_0 [simp]: "new_array v 0 = Array []"
by(simp add: new_array_def)
lemma array_of_list_Nil [simp]:
"array_of_list [] = Array []"
by(simp add: array_of_list_def)
lemma array_map_Nil [simp]:
"array_map f (Array []) = Array []"
by(simp add: array_map_def)
lemma array_foldl_Nil [simp]:
"array_foldl f b (Array []) = b"
by(simp add: array_foldl_def)
lemma array_foldr_Nil [simp]:
"array_foldr f (Array []) b = b"
by(simp add: array_foldr_def)
lemma prod_foldl_conv:
"(foldl f a xs, foldl g b xs) = foldl (λ(a, b) x. (f a x, g b x)) (a, b) xs"
by(induct xs arbitrary: a b) simp_all
lemma prod_array_foldl_conv:
"(array_foldl f b a, array_foldl g c a) = array_foldl (λh (b, c) v. (f h b v, g h c v)) (b, c) a"
by(cases a)(simp add: array_foldl_def foldl_map prod_foldl_conv split_def)
lemma array_foldl_array_foldr_comm:
"comp_fun_commute (λ(h, v) b. f h b v) ⟹ array_foldl f b a = array_foldr (λh v b. f h b v) a b"
by(cases a)(simp add: array_foldl_def array_foldr_def split_def comp_fun_commute.foldr_conv_foldl)
lemma array_map_conv_array_foldl:
"array_map f a = array_foldl (λh a v. array_set a h (f h v)) a a"
proof(cases a)
case (Array xs)
define a where "a = xs"
hence "length xs ≤ length a" by simp
hence "foldl (λa (k, v). array_set a k (f k v))
(Array a) (zip [0..<length xs] xs)
= Array (map (λ(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a)"
proof(induct xs rule: rev_induct)
case Nil thus ?case by simp
next
case (snoc x xs)
have "foldl (λa (k, v). array_set a k (f k v)) (Array a) (zip [0..<length (xs @ [x])] (xs @ [x])) =
array_set (foldl (λa (k, v). array_set a k (f k v)) (Array a) (zip [0..<length xs] xs))
(length xs) (f (length xs) x)" by simp
also from ‹length (xs @ [x]) ≤ length a› have "length xs ≤ length a" by simp
hence "foldl (λa (k, v). array_set a k (f k v)) (Array a) (zip [0..<length xs] xs) =
Array (map (λ(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a)" by(rule snoc)
also note array_set.simps
also have "(map (λ(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a) [length xs := f (length xs) x] =
(map (λ(k, v). f k v) (zip [0..<length xs] xs) @ (drop (length xs) a) [0 := f (length xs) x])"
by(simp add: list_update_append)
also from ‹length (xs @ [x]) ≤ length a›
have "(drop (length xs) a)[0 := f (length xs) x] =
f (length xs) x # drop (Suc (length xs)) a"
by(simp add: upd_conv_take_nth_drop)
also have "map (λ(k, v). f k v) (zip [0..<length xs] xs) @ f (length xs) x # drop (Suc (length xs)) a =
(map (λ(k, v). f k v) (zip [0..<length xs] xs) @ [f (length xs) x]) @ drop (Suc (length xs)) a" by simp
also have "… = map (λ(k, v). f k v) (zip [0..<length (xs @ [x])] (xs @ [x])) @ drop (length (xs @ [x])) a"
by(simp)
finally show ?case .
qed
with a_def Array show ?thesis
by(simp add: array_foldl_def array_map_def array_of_list_def)
qed
lemma array_foldl_new_array:
"array_foldl f b (new_array a n) = foldl (λb (k, v). f k b v) b (zip [0..<n] (replicate n a))"
by(simp add: new_array_def array_foldl_def)
lemma array_list_of_set[simp]:
"list_of_array (array_set a i x) = (list_of_array a) [i := x]"
by (cases a) simp
lemma array_length_list: "array_length a = length (list_of_array a)"
by (cases a) simp
subsection ‹Parametricity lemmas›
lemma rec_array_is_case[simp]: "rec_array = case_array"
apply (intro ext)
apply (auto split: array.split)
done
definition array_rel_def_internal:
"array_rel R ≡
{(Array xs, Array ys)|xs ys. (xs,ys) ∈ ⟨R⟩list_rel}"
lemma array_rel_def:
"⟨R⟩array_rel ≡ {(Array xs, Array ys)|xs ys. (xs,ys) ∈ ⟨R⟩list_rel}"
unfolding array_rel_def_internal relAPP_def .
lemma array_relD:
"(Array l, Array l') ∈ ⟨R⟩array_rel ⟹ (l,l') ∈ ⟨R⟩list_rel"
by (simp add: array_rel_def)
lemma array_rel_alt:
"⟨R⟩array_rel =
{ (Array l, l) | l. True }
O ⟨R⟩list_rel
O {(l,Array l) | l. True}"
by (auto simp: array_rel_def)
lemma array_rel_sv[relator_props]:
shows "single_valued R ⟹ single_valued (⟨R⟩array_rel)"
unfolding array_rel_alt
apply (intro relator_props )
apply (auto intro: single_valuedI)
done
lemma param_Array[param]:
"(Array,Array) ∈ ⟨R⟩ list_rel → ⟨R⟩ array_rel"
apply (intro fun_relI)
apply (simp add: array_rel_def)
done
lemma param_rec_array[param]:
"(rec_array,rec_array) ∈ (⟨Ra⟩list_rel → Rb) → ⟨Ra⟩array_rel → Rb"
apply (intro fun_relI)
apply (rename_tac f f' a a', case_tac a, case_tac a')
apply (auto dest: fun_relD array_relD)
done
lemma param_case_array[param]:
"(case_array,case_array) ∈ (⟨Ra⟩list_rel → Rb) → ⟨Ra⟩array_rel → Rb"
apply (clarsimp split: array.split)
apply (drule array_relD)
by parametricity
lemma param_case_array1':
assumes "(a,a')∈⟨Ra⟩array_rel"
assumes "⋀l l'. ⟦ a=Array l; a'=Array l'; (l,l')∈⟨Ra⟩list_rel ⟧
⟹ (f l,f' l') ∈ Rb"
shows "(case_array f a,case_array f' a') ∈ Rb"
using assms
apply (clarsimp split: array.split)
apply (drule array_relD)
apply parametricity
by (rule refl)+
lemmas param_case_array2' = param_case_array1'[folded rec_array_is_case]
lemmas param_case_array' = param_case_array1' param_case_array2'
lemma param_array_length[param]:
"(array_length,array_length) ∈ ⟨Rb⟩array_rel → nat_rel"
unfolding array_length_def
by parametricity
lemma param_array_grow[param]:
"(array_grow,array_grow) ∈ ⟨R⟩array_rel → nat_rel → R → ⟨R⟩array_rel"
unfolding array_grow_def by parametricity
lemma array_rel_imp_same_length:
"(a, a') ∈ ⟨R⟩array_rel ⟹ array_length a = array_length a'"
apply (cases a, cases a')
apply (auto simp add: list_rel_imp_same_length dest!: array_relD)
done
lemma param_array_get[param]:
assumes I: "i<array_length a"
assumes IR: "(i,i')∈nat_rel"
assumes AR: "(a,a')∈⟨R⟩array_rel"
shows "(array_get a i, array_get a' i') ∈ R"
proof -
obtain l l' where [simp]: "a = Array l" "a' = Array l'"
by (cases a, cases a', simp_all)
from AR have LR: "(l,l') ∈ ⟨R⟩list_rel" by (force dest!: array_relD)
thus ?thesis using assms
unfolding array_get_def
apply (auto intro!: param_nth[param_fo] dest: list_rel_imp_same_length)
done
qed
lemma param_array_set[param]:
"(array_set,array_set)∈⟨R⟩array_rel→nat_rel→R→⟨R⟩array_rel"
unfolding array_set_def by parametricity
lemma param_array_of_list[param]:
"(array_of_list, array_of_list) ∈ ⟨R⟩ list_rel → ⟨R⟩ array_rel"
unfolding array_of_list_def by parametricity
lemma param_array_shrink[param]:
assumes N: "array_length a ≥ n"
assumes NR: "(n,n')∈nat_rel"
assumes AR: "(a,a')∈⟨R⟩array_rel"
shows "(array_shrink a n, array_shrink a' n') ∈ ⟨R⟩ array_rel"
proof-
obtain l l' where [simp]: "a = Array l" "a' = Array l'"
by (cases a, cases a', simp_all)
from AR have LR: "(l,l') ∈ ⟨R⟩list_rel"
by (auto dest: array_relD)
with assms show ?thesis by (auto intro:
param_Array[param_fo] param_take[param_fo]
dest: array_rel_imp_same_length
)
qed
lemma param_assoc_list_of_array[param]:
"(assoc_list_of_array, assoc_list_of_array) ∈
⟨R⟩ array_rel → ⟨⟨nat_rel,R⟩prod_rel⟩list_rel"
unfolding assoc_list_of_array_def[abs_def] by parametricity
lemma param_array_map[param]:
"(array_map, array_map) ∈
(nat_rel → Ra → Rb) → ⟨Ra⟩array_rel → ⟨Rb⟩array_rel"
unfolding array_map_def[abs_def] by parametricity
lemma param_array_foldr[param]:
"(array_foldr, array_foldr) ∈
(nat_rel → Ra → Rb → Rb) → ⟨Ra⟩array_rel → Rb → Rb"
unfolding array_foldr_def[abs_def] by parametricity
lemma param_array_foldl[param]:
"(array_foldl, array_foldl) ∈
(nat_rel → Rb → Ra → Rb) → Rb → ⟨Ra⟩array_rel → Rb"
unfolding array_foldl_def[abs_def] by parametricity
subsection ‹Code Generator Setup›
subsubsection ‹Code-Numeral Preparation›
definition [code del]: "new_array' v == new_array v o nat_of_integer"
definition [code del]: "array_length' == integer_of_nat o array_length"
definition [code del]: "array_get' a == array_get a o nat_of_integer"
definition [code del]: "array_set' a == array_set a o nat_of_integer"
definition [code del]: "array_grow' a == array_grow a o nat_of_integer"
definition [code del]: "array_shrink' a == array_shrink a o nat_of_integer"
definition [code del]:
"array_get_oo' x a == array_get_oo x a o nat_of_integer"
definition [code del]:
"array_set_oo' f a == array_set_oo f a o nat_of_integer"
lemma [code]:
"new_array v == new_array' v o integer_of_nat"
"array_length == nat_of_integer o array_length'"
"array_get a == array_get' a o integer_of_nat"
"array_set a == array_set' a o integer_of_nat"
"array_grow a == array_grow' a o integer_of_nat"
"array_shrink a == array_shrink' a o integer_of_nat"
"array_get_oo x a == array_get_oo' x a o integer_of_nat"
"array_set_oo f a == array_set_oo' f a o integer_of_nat"
by (simp_all
add: o_def
add: new_array'_def array_length'_def array_get'_def array_set'_def
array_grow'_def array_shrink'_def array_get_oo'_def array_set_oo'_def)
text ‹Fallbacks›
lemmas [code] = array_get_oo'_def[unfolded array_get_oo_def[abs_def]]
lemmas [code] = array_set_oo'_def[unfolded array_set_oo_def[abs_def]]
subsubsection ‹Code generator setup for Haskell›
code_printing type_constructor array ⇀
(Haskell) "Array.ArrayType/ _"
code_reserved Haskell array_of_list
code_printing code_module "Array" ⇀
(Haskell) ‹module Array where {
--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;
type ArrayType = Arr.Array Integer;
array_of_size :: Integer -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (0, n-1);
new_array :: e -> Integer -> ArrayType e;
new_array a n = array_of_size n (repeat a);
array_length :: ArrayType e -> Integer;
array_length a = let (s, e) = Arr.bounds a in e;
array_get :: ArrayType e -> Integer -> e;
array_get a i = a Arr.! i;
array_set :: ArrayType e -> Integer -> e -> ArrayType e;
array_set a i e = a Arr.// [(i, e)];
array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (toInteger (length xs)) xs;
array_grow :: ArrayType e -> Integer -> e -> ArrayType e;
array_grow a i x = let (s, e) = Arr.bounds a in Arr.listArray (s, e+i) (Arr.elems a ++ repeat x);
array_shrink :: ArrayType e -> Integer -> ArrayType e;
array_shrink a sz = if sz > array_length a then undefined else array_of_size sz (Arr.elems a);
}›
code_printing constant Array ⇀ (Haskell) "Array.array'_of'_list"
code_printing constant new_array' ⇀ (Haskell) "Array.new'_array"
code_printing constant array_length' ⇀ (Haskell) "Array.array'_length"
code_printing constant array_get' ⇀ (Haskell) "Array.array'_get"
code_printing constant array_set' ⇀ (Haskell) "Array.array'_set"
code_printing constant array_of_list ⇀ (Haskell) "Array.array'_of'_list"
code_printing constant array_grow' ⇀ (Haskell) "Array.array'_grow"
code_printing constant array_shrink' ⇀ (Haskell) "Array.array'_shrink"
subsubsection ‹Code Generator Setup For SML›
text ‹
We have the choice between single-threaded arrays, that raise an exception if an old version is accessed,
and truly functional arrays, that update the array in place, but store undo-information to restore
old versions.
›
code_printing code_module "STArray" ⇀
(SML)
‹
structure STArray = struct
datatype 'a Cell = Invalid | Value of 'a array;
exception AccessedOldVersion;
type 'a array = 'a Cell Unsynchronized.ref;
fun fromList l = Unsynchronized.ref (Value (Array.fromList l));
fun array (size, v) = Unsynchronized.ref (Value (Array.array (size,v)));
fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
fun sub (Unsynchronized.ref Invalid, idx) = raise AccessedOldVersion |
sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx);
fun update (aref,idx,v) =
case aref of
(Unsynchronized.ref Invalid) => raise AccessedOldVersion |
(Unsynchronized.ref (Value a)) => (
aref := Invalid;
Array.update (a,idx,v);
Unsynchronized.ref (Value a)
);
fun length (Unsynchronized.ref Invalid) = raise AccessedOldVersion |
length (Unsynchronized.ref (Value a)) = Array.length a
fun grow (aref, i, x) = case aref of
(Unsynchronized.ref Invalid) => raise AccessedOldVersion |
(Unsynchronized.ref (Value a)) => (
let val len=Array.length a;
val na = Array.array (len+i,x)
in
aref := Invalid;
Array.copy {src=a, dst=na, di=0};
Unsynchronized.ref (Value na)
end
);
fun shrink (aref, sz) = case aref of
(Unsynchronized.ref Invalid) => raise AccessedOldVersion |
(Unsynchronized.ref (Value a)) => (
if sz > Array.length a then
raise Size
else (
aref:=Invalid;
Unsynchronized.ref (Value (Array.tabulate (sz,fn i => Array.sub (a,i))))
)
);
structure IsabelleMapping = struct
type 'a ArrayType = 'a array;
fun new_array (a:'a) (n:IntInf.int) = array (IntInf.toInt n, a);
fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);
fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);
fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);
fun array_of_list (xs:'a list) = fromList xs;
fun array_grow (a:'a ArrayType) (i:IntInf.int) (x:'a) = grow (a, IntInf.toInt i, x);
fun array_shrink (a:'a ArrayType) (sz:IntInf.int) = shrink (a,IntInf.toInt sz);
end;
end;
structure FArray = struct
datatype 'a Cell = Value of 'a Array.array | Upd of (int*'a*'a Cell Unsynchronized.ref);
type 'a array = 'a Cell Unsynchronized.ref;
fun array (size,v) = Unsynchronized.ref (Value (Array.array (size,v)));
fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
fun fromList l = Unsynchronized.ref (Value (Array.fromList l));
fun sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx) |
sub (Unsynchronized.ref (Upd (i,v,cr)),idx) =
if i=idx then v
else sub (cr,idx);
fun length (Unsynchronized.ref (Value a)) = Array.length a |
length (Unsynchronized.ref (Upd (i,v,cr))) = length cr;
fun realize_aux (aref, v) =
case aref of
(Unsynchronized.ref (Value a)) => (
let
val len = Array.length a;
val a' = Array.array (len,v);
in
Array.copy {src=a, dst=a', di=0};
Unsynchronized.ref (Value a')
end
) |
(Unsynchronized.ref (Upd (i,v,cr))) => (
let val res=realize_aux (cr,v) in
case res of
(Unsynchronized.ref (Value a)) => (Array.update (a,i,v); res)
end
);
fun realize aref =
case aref of
(Unsynchronized.ref (Value _)) => aref |
(Unsynchronized.ref (Upd (i,v,cr))) => realize_aux(aref,v);
fun update (aref,idx,v) =
case aref of
(Unsynchronized.ref (Value a)) => (
let val nref=Unsynchronized.ref (Value a) in
aref := Upd (idx,Array.sub(a,idx),nref);
Array.update (a,idx,v);
nref
end
) |
(Unsynchronized.ref (Upd _)) =>
let val ra = realize_aux(aref,v) in
case ra of
(Unsynchronized.ref (Value a)) => Array.update (a,idx,v);
ra
end
;
fun grow (aref, inc, x) = case aref of
(Unsynchronized.ref (Value a)) => (
let val len=Array.length a;
val na = Array.array (len+inc,x)
in
Array.copy {src=a, dst=na, di=0};
Unsynchronized.ref (Value na)
end
)
| (Unsynchronized.ref (Upd _)) => (
grow (realize aref, inc, x)
);
fun shrink (aref, sz) = case aref of
(Unsynchronized.ref (Value a)) => (
if sz > Array.length a then
raise Size
else (
Unsynchronized.ref (Value (Array.tabulate (sz,fn i => Array.sub (a,i))))
)
) |
(Unsynchronized.ref (Upd _)) => (
shrink (realize aref,sz)
);
structure IsabelleMapping = struct
type 'a ArrayType = 'a array;
fun new_array (a:'a) (n:IntInf.int) = array (IntInf.toInt n, a);
fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);
fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);
fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);
fun array_of_list (xs:'a list) = fromList xs;
fun array_grow (a:'a ArrayType) (i:IntInf.int) (x:'a) = grow (a, IntInf.toInt i, x);
fun array_shrink (a:'a ArrayType) (sz:IntInf.int) = shrink (a,IntInf.toInt sz);
fun array_get_oo (d:'a) (a:'a ArrayType) (i:IntInf.int) =
sub (a,IntInf.toInt i) handle Subscript => d
fun array_set_oo (d:(unit->'a ArrayType)) (a:'a ArrayType) (i:IntInf.int) (e:'a) =
update (a, IntInf.toInt i, e) handle Subscript => d ()
end;
end;
›
code_printing
type_constructor array ⇀ (SML) "_/ FArray.IsabelleMapping.ArrayType"
| constant Array ⇀ (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant new_array' ⇀ (SML) "FArray.IsabelleMapping.new'_array"
| constant array_length' ⇀ (SML) "FArray.IsabelleMapping.array'_length"
| constant array_get' ⇀ (SML) "FArray.IsabelleMapping.array'_get"
| constant array_set' ⇀ (SML) "FArray.IsabelleMapping.array'_set"
| constant array_grow' ⇀ (SML) "FArray.IsabelleMapping.array'_grow"
| constant array_shrink' ⇀ (SML) "FArray.IsabelleMapping.array'_shrink"
| constant array_of_list ⇀ (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant array_get_oo' ⇀ (SML) "FArray.IsabelleMapping.array'_get'_oo"
| constant array_set_oo' ⇀ (SML) "FArray.IsabelleMapping.array'_set'_oo"
subsection ‹Code Generator Setup for Scala›
text ‹
We use a DiffArray-Implementation in Scala.
›
code_printing code_module "DiffArray" ⇀
(Scala) ‹
object DiffArray {
import scala.collection.mutable.ArraySeq
protected abstract sealed class DiffArray_D[A]
final case class Current[A] (a:ArraySeq[AnyRef]) extends DiffArray_D[A]
final case class Upd[A] (i:Int, v:A, n:DiffArray_D[A]) extends DiffArray_D[A]
object DiffArray_Realizer {
def realize[A](a:DiffArray_D[A]) : ArraySeq[AnyRef] = a match {
case Current(a) => ArraySeq.empty ++ a
case Upd(j,v,n) => {val a = realize(n); a.update(j, v.asInstanceOf[AnyRef]); a}
}
}
class T[A] (var d:DiffArray_D[A]) {
def realize (): ArraySeq[AnyRef] = { val a=DiffArray_Realizer.realize(d); d = Current(a); a }
override def toString() = realize().toSeq.toString
override def equals(obj:Any) =
if (obj.isInstanceOf[T[A]]) obj.asInstanceOf[T[A]].realize().equals(realize())
else false
}
def array_of_list[A](l : List[A]) : T[A] = new T(Current(ArraySeq.empty ++ l.asInstanceOf[List[AnyRef]]))
def new_array[A](v:A, sz : BigInt) = new T[A](Current[A](ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])))
private def length[A](a:DiffArray_D[A]) : BigInt = a match {
case Current(a) => a.length
case Upd(_,_,n) => length(n)
}
def length[A](a : T[A]) : BigInt = length(a.d)
private def sub[A](a:DiffArray_D[A], i:Int) : A = a match {
case Current(a) => a(i).asInstanceOf[A]
case Upd(j,v,n) => if (i==j) v else sub(n,i)
}
def get[A](a:T[A], i:BigInt) : A = sub(a.d,i.intValue)
private def realize[A](a:DiffArray_D[A]): ArraySeq[AnyRef] = DiffArray_Realizer.realize[A](a)
def set[A](a:T[A], i:BigInt,v:A) : T[A] = a.d match {
case Current(ad) => {
val ii = i.intValue;
a.d = Upd(ii,ad(ii).asInstanceOf[A],a.d);
//ad.update(ii,v);
ad(ii)=v.asInstanceOf[AnyRef]
new T[A](Current(ad))
}
case Upd(_,_,_) => set(new T[A](Current(realize(a.d))), i.intValue,v)
}
def grow[A](a:T[A], sz:BigInt, v:A) : T[A] = a.d match {
case Current(ad) => {
val adt = ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])
System.arraycopy(ad.array, 0, adt.array, 0, ad.length);
new T[A](Current[A](adt))
}
case Upd (_,_,_) => {
val adt = ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])
val ad = realize(a.d)
System.arraycopy(ad.array, 0, adt.array, 0, ad.length);
new T[A](Current[A](adt))
}
}
def shrink[A](a:T[A], sz:BigInt) : T[A] =
if (sz==0) {
array_of_list(Nil)
} else {
a.d match {
case Current(ad) => {
val v=ad(0);
val szz=sz.intValue
val adt = ArraySeq.fill[AnyRef](szz)(v);
System.arraycopy(ad.array, 0, adt.array, 0, szz);
new T[A](Current[A](adt))
}
case Upd (_,_,_) => {
val ad = realize(a.d);
val szz=sz.intValue
val v=ad(0);
val adt = ArraySeq.fill[AnyRef](szz)(v);
System.arraycopy(ad.array, 0, adt.array, 0, szz);
new T[A](Current[A](adt))
}
}
}
def get_oo[A](d: => A, a:T[A], i:BigInt):A = try get(a,i) catch {
case _:scala.IndexOutOfBoundsException => d
}
def set_oo[A](d: Unit => T[A], a:T[A], i:BigInt, v:A) : T[A] = try set(a,i,v) catch {
case _:scala.IndexOutOfBoundsException => d(())
}
}
/*
object Test {
def assert (b : Boolean) : Unit = if (b) () else throw new java.lang.AssertionError("Assertion Failed")
def eql[A] (a:DiffArray.T[A], b:List[A]) = assert (a.realize.corresponds(b)((x,y) => x.equals(y)))
def tests1(): Unit = {
val a = DiffArray.array_of_list(1::2::3::4::Nil)
eql(a,1::2::3::4::Nil)
// Simple update
val b = DiffArray.set(a,2,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
// Another update
val c = DiffArray.set(b,3,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::9::9::Nil)
// Update of old version (forces realize)
val d = DiffArray.set(b,2,8)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::9::9::Nil)
eql(d,1::2::8::4::Nil)
}
def tests2(): Unit = {
val a = DiffArray.array_of_list(1::2::3::4::Nil)
eql(a,1::2::3::4::Nil)
// Simple update
val b = DiffArray.set(a,2,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
// Grow of current version
val c = DiffArray.grow(b,6,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::9::4::9::9::Nil)
// Grow of old version
val d = DiffArray.grow(a,6,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::9::4::9::9::Nil)
eql(d,1::2::3::4::9::9::Nil)
}
def tests3(): Unit = {
val a = DiffArray.array_of_list(1::2::3::4::Nil)
eql(a,1::2::3::4::Nil)
// Simple update
val b = DiffArray.set(a,2,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
// Shrink of current version
val c = DiffArray.shrink(b,3)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::9::Nil)
// Shrink of old version
val d = DiffArray.shrink(a,3)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::9::Nil)
eql(d,1::2::3::Nil)
}
def tests4(): Unit = {
val a = DiffArray.array_of_list(1::2::3::4::Nil)
eql(a,1::2::3::4::Nil)
// Update _oo (succeeds)
val b = DiffArray.set_oo((_) => a,a,2,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
// Update _oo (current version,fails)
val c = DiffArray.set_oo((_) => a,b,5,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::3::4::Nil)
// Update _oo (old version,fails)
val d = DiffArray.set_oo((_) => b,a,5,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
eql(c,1::2::3::4::Nil)
eql(d,1::2::9::4::Nil)
}
def tests5(): Unit = {
val a = DiffArray.array_of_list(1::2::3::4::Nil)
eql(a,1::2::3::4::Nil)
// Update
val b = DiffArray.set(a,2,9)
eql(a,1::2::3::4::Nil)
eql(b,1::2::9::4::Nil)
// Get_oo (current version, succeeds)
assert (DiffArray.get_oo(0,b,2)==9)
// Get_oo (current version, fails)
assert (DiffArray.get_oo(0,b,5)==0)
// Get_oo (old version, succeeds)
assert (DiffArray.get_oo(0,a,2)==3)
// Get_oo (old version, fails)
assert (DiffArray.get_oo(0,a,5)==0)
}
def main(args: Array[String]): Unit = {
tests1 ()
tests2 ()
tests3 ()
tests4 ()
tests5 ()
Console.println("Tests passed")
}
}*/
›
code_printing
type_constructor array ⇀ (Scala) "DiffArray.T[_]"
| constant Array ⇀ (Scala) "DiffArray.array'_of'_list"
| constant new_array' ⇀ (Scala) "DiffArray.new'_array((_),(_).toInt)"
| constant array_length' ⇀ (Scala) "DiffArray.length((_)).toInt"
| constant array_get' ⇀ (Scala) "DiffArray.get((_),(_).toInt)"
| constant array_set' ⇀ (Scala) "DiffArray.set((_),(_).toInt,(_))"
| constant array_grow' ⇀ (Scala) "DiffArray.grow((_),(_).toInt,(_))"
| constant array_shrink' ⇀ (Scala) "DiffArray.shrink((_),(_).toInt)"
| constant array_of_list ⇀ (Scala) "DiffArray.array'_of'_list"
| constant array_get_oo' ⇀ (Scala) "DiffArray.get'_oo((_),(_),(_).toInt)"
| constant array_set_oo' ⇀ (Scala) "DiffArray.set'_oo((_),(_),(_).toInt,(_))"
context begin
definition "test_diffarray_setup ≡ (Array,new_array',array_length',array_get', array_set', array_grow', array_shrink',array_of_list,array_get_oo',array_set_oo')"
export_code test_diffarray_setup checking Scala SML OCaml? Haskell?
end
end
Theory Partial_Equivalence_Relation
theory Partial_Equivalence_Relation
imports Main
begin
subsection ‹Partial Equivalence Relations›
text ‹
The abstract datatype for a union-find structure is a partial equivalence
relation.
›
definition "part_equiv R ≡ sym R ∧ trans R"
lemma part_equivI[intro?]: "⟦sym R; trans R⟧ ⟹ part_equiv R"
by (simp add: part_equiv_def)
lemma part_equiv_refl:
"part_equiv R ⟹ (x,y)∈R ⟹ (x,x)∈R"
"part_equiv R ⟹ (x,y)∈R ⟹ (y,y)∈R"
by (metis part_equiv_def symD transD)+
lemma part_equiv_sym: "part_equiv R ⟹ (x,y)∈R ⟹ (y,x)∈R"
by (metis part_equiv_def symD)
lemma part_equiv_trans: "part_equiv R ⟹ (x,y)∈R ⟹ (y,z)∈R ⟹ (x,z)∈R"
by (metis part_equiv_def transD)
lemma part_equiv_trans_sym:
"⟦ part_equiv R; (a,b)∈R; (c,b)∈R ⟧ ⟹ (a,c)∈R"
"⟦ part_equiv R; (a,b)∈R; (a,c)∈R ⟧ ⟹ (b,c)∈R"
apply (metis part_equiv_sym part_equiv_trans)+
done
text ‹We define a shortcut for symmetric closure.›
definition "symcl R ≡ R ∪ R¯"
lemma sym_symcl[simp, intro!]: "sym (symcl R)"
by (metis sym_Un_converse symcl_def)
lemma sym_trans_is_part_equiv[simp, intro!]: "part_equiv ((symcl R)⇧*)"
by (metis part_equiv_def sym_rtrancl sym_symcl trans_rtrancl)
text ‹We also define a shortcut for melding the equivalence classes of
two given elements›
definition per_union where "per_union R a b ≡ R ∪
{ (x,y). (x,a)∈R ∧ (y,b)∈R } ∪ { (y,x). (x,a)∈R ∧ (y,b)∈R }"
lemma union_part_equivp:
"part_equiv R ⟹ part_equiv (per_union R a b)"
apply rule
unfolding per_union_def
apply (rule symI)
apply (auto dest: part_equiv_sym) []
apply (rule transI)
apply (auto dest: part_equiv_trans part_equiv_trans_sym)
done
lemma per_union_cmp:
"⟦ part_equiv R; (l,j)∈R ⟧ ⟹ per_union R l j = R"
unfolding per_union_def by (auto dest: part_equiv_trans_sym)
lemma per_union_same[simp]: "part_equiv R ⟹ per_union R l l = R"
unfolding per_union_def by (auto dest: part_equiv_trans_sym)
lemma per_union_commute[simp]: "per_union R i j = per_union R j i"
unfolding per_union_def by auto
lemma per_union_dom[simp]: "Domain (per_union R i j) = Domain R"
unfolding per_union_def by auto
lemma per_classes_dj:
"⟦part_equiv R; (i,j)∉R⟧ ⟹ R``{i} ∩ R``{j} = {}"
by (auto dest: part_equiv_trans_sym)
lemma per_class_in_dom: "⟦part_equiv R⟧ ⟹ R``{i} ⊆ Domain R"
by (auto dest: part_equiv_trans_sym)
end
Theory ICF_Tools
section ‹General ML-level tools›
theory ICF_Tools
imports Main
begin
lemma meta_same_imp_rule: "(⟦PROP P; PROP P⟧ ⟹ PROP Q) ≡ (PROP P ⟹ PROP Q)"
by rule
ML ‹
infix 0 ##;
fun (f ## g) (a,b) = (f a, g b)
signature ICF_TOOLS = sig
val gen_variant: (string -> bool) -> string -> string
val map_option: ('a -> 'b) -> 'a option -> 'b option
val parse_cpat: cterm context_parser
val rename_cterm: (cterm * cterm) ->
((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list
val renames_cterm: (cterm * cterm) -> bool
val import_cterm: cterm -> Proof.context -> cterm * Proof.context
val inst_meta_cong: Proof.context -> cterm -> thm
val sss_add: thm list -> Proof.context -> Proof.context
val changed_conv: conv -> conv
val repeat_top_sweep_conv: (Proof.context -> conv) -> Proof.context -> conv
val rem_dup_prems: Proof.context -> thm -> thm
val dest_def_eq: term -> term * term
val norm_def_thm: thm -> thm
val dthm_lhs: thm -> term
val dthm_rhs: thm -> term
val dthm_params: thm -> term list
val dthm_head: thm -> term
val dt_lhs: term -> term
val dt_rhs: term -> term
val dt_params: term -> term list
val dt_head: term -> term
val chead_of: cterm -> cterm
val chead_of_thm: thm -> cterm
val define_simple: string -> term -> local_theory
-> ((term * thm) * local_theory)
val wrap_lthy_result_global: (local_theory -> 'a * local_theory) ->
(morphism -> 'a -> 'b) -> theory -> 'b * theory
val wrap_lthy_global: (local_theory -> local_theory) -> theory -> theory
val wrap_lthy_result_local: (local_theory -> 'a * local_theory) ->
(morphism -> 'a -> 'b) -> local_theory -> 'b * local_theory
val wrap_lthy_local: (local_theory -> local_theory) ->
local_theory -> local_theory
val define_simple_global: string -> term -> theory
-> ((term * thm) * theory)
val define_simple_local: string -> term -> local_theory
-> ((term * thm) * local_theory)
val revert_abbrevs: string -> theory -> theory
end;
structure ICF_Tools: ICF_TOOLS = struct
fun gen_variant decl s = let
fun search s = if not (decl s) then s else search (Symbol.bump_string s);
in
if not (decl s) then s
else search (Symbol.bump_init s)
end;
val parse_cpat =
Args.context --
Scan.lift Args.embedded_inner_syntax >> (fn (ctxt, str) =>
Proof_Context.read_term_pattern ctxt str
|> Thm.cterm_of ctxt
);
fun rename_cterm (ct1,ct2) = (
Thm.first_order_match (ct2,ct1);
Thm.first_order_match (ct1,ct2));
val renames_cterm = can rename_cterm;
fun import_cterm ct ctxt = let
val (t', ctxt') = yield_singleton (Variable.import_terms true)
(Thm.term_of ct) ctxt;
val ct' = Thm.cterm_of ctxt' t';
in (ct', ctxt') end
local
fun sss_add_single thm ss = let
val simps = Raw_Simplifier.dest_ss (simpset_of ss) |> #simps |> map #2;
val ess = ss delsimps simps;
val thm' = simplify ss thm;
val new_simps = simps
|> map (simplify
(ess addsimps [thm']));
val ss' = ess addsimps (thm'::new_simps)
in ss' end
in
val sss_add = fold sss_add_single
end
local
open Conv;
in
fun changed_conv cnv = (fn (ct:cterm) => let
val thm = cnv ct
in
if Thm.is_reflexive thm then
raise THM ("changed_conv: Not changed",~1,[thm])
else thm
end)
fun repeat_top_sweep_conv cnv ctxt =
repeat_conv (changed_conv (top_sweep_conv cnv ctxt));
end
fun rem_dup_prems ctxt thm = let
val prems = Thm.prems_of thm;
val perm = prems
|> tag_list 0
|> map swap
|> Termtab.make_list
|> Termtab.dest
|> map snd
|> sort (int_ord o apply2 hd)
|> flat;
val thm' = Drule.rearrange_prems perm thm
|> Conv.fconv_rule
(Raw_Simplifier.rewrite ctxt true @{thms meta_same_imp_rule});
in thm' end;
fun dest_def_eq (Const (@{const_name Pure.eq},_)$l$r) = (l,r)
| dest_def_eq (Const (@{const_name HOL.Trueprop},_)
$(Const (@{const_name HOL.eq},_)$l$r)) = (l,r)
| dest_def_eq t = raise TERM ("No definitional equation",[t]);
fun norm_def_thm thm =
case Thm.concl_of thm of
(Const (@{const_name Pure.eq},_)$_$_) => thm
| _ => thm RS eq_reflection;
val dt_lhs = dest_def_eq #> fst;
val dt_rhs = dest_def_eq #> snd;
val dt_params = dt_lhs #> strip_comb #> snd;
val dt_head = dt_lhs #> head_of;
val dthm_lhs = Thm.concl_of #> dt_lhs;
val dthm_rhs = Thm.concl_of #> dt_rhs;
val dthm_params = Thm.concl_of #> dt_params;
val dthm_head = Thm.concl_of #> dt_head;
fun chead_of ct = case Thm.term_of ct of
(_$_) => chead_of (Thm.dest_fun ct)
| _ => ct;
val chead_of_thm = norm_def_thm #> Thm.lhs_of #> chead_of;
val meta_cong_rl = @{thm "eq_reflection"}
OF @{thms "arg_cong"} OF @{thms "meta_eq_to_obj_eq"}
fun inst_meta_cong ctxt ct = let
val (ct, ctxt') = import_cterm ct ctxt;
val mc_thm = meta_cong_rl;
val fpat = mc_thm |> Thm.cprop_of |> Drule.strip_imp_concl
|> Thm.dest_arg1 |> chead_of;
val inst = infer_instantiate ctxt [(#1 (dest_Var (Thm.term_of fpat)), ct)] mc_thm;
val inst' = singleton (Variable.export ctxt' ctxt) inst;
in inst' end
fun define_simple name rhs lthy = let
val (rhs,lthy) = yield_singleton Variable.importT_terms rhs lthy;
val ((ft,(_,def_thm)),lthy)
= Local_Theory.define ((Binding.name name,NoSyn),
((Binding.name (Thm.def_name name),[]),rhs)) lthy;
in ((ft,def_thm),lthy) end;
fun wrap_lthy_result_global f rmap thy = let
val lthy = Named_Target.theory_init thy;
val (r,lthy) = f lthy;
val (r,thy) = Local_Theory.exit_result_global rmap (r,lthy);
in
(r,thy)
end
fun wrap_lthy_global f = wrap_lthy_result_global (pair () o f) (K I) #> #2;
fun wrap_lthy_result_local f rmap lthy = let
val lthy = (snd o Local_Theory.begin_nested) lthy;
val (r,lthy) = f lthy;
val m = Local_Theory.target_morphism lthy;
val lthy = Local_Theory.end_nested lthy;
val r = rmap m r;
in
(r,lthy)
end
fun wrap_lthy_local f = wrap_lthy_result_local (pair () o f) (K I) #> #2;
fun define_simple_global name rhs thy = let
val lthy = Named_Target.theory_init thy;
val (r,lthy) = define_simple name rhs lthy;
fun map_res m (t,thm) = (Morphism.term m t,Morphism.thm m thm);
val (r,thy) = Local_Theory.exit_result_global (map_res) (r,lthy);
in (r,thy) end;
fun define_simple_local name rhs lthy = let
val lthy = (snd o Local_Theory.begin_nested) lthy;
val (r,lthy) = define_simple name rhs lthy;
val m = Local_Theory.target_morphism lthy;
val lthy = Local_Theory.end_nested lthy;
fun map_res m (t,thm) = (Morphism.term m t,Morphism.thm m thm);
val (r,lthy) = (map_res m r,lthy);
in (r,lthy) end;
fun map_option _ NONE = NONE
| map_option f (SOME a) = SOME (f a);
fun revert_abbrevs mpat thy = let
val ctxt = Proof_Context.init_global thy;
val match_prefix = if Long_Name.is_qualified mpat then mpat
else Long_Name.qualify (Context.theory_name thy) mpat;
val {const_space, constants, ...} = Sign.consts_of thy |> Consts.dest;
val names =
Name_Space.extern_entries true ctxt const_space constants
|> map_filter (fn
((name, _), (_, SOME _)) =>
if Long_Name.qualifier name = match_prefix then SOME name else NONE
| _ => NONE)
val _ = if null names then
warning ("ICF_Tools.revert_abbrevs: No names with prefix: "
^ match_prefix)
else ();
in fold (Sign.revert_abbrev "") names thy end
end;
›
attribute_setup rem_dup_prems = ‹
Scan.succeed (Thm.rule_attribute [] (ICF_Tools.rem_dup_prems o Context.proof_of))
› "Remove duplicate premises"
method_setup dup_subgoals = ‹
Scan.succeed (fn ctxt => SIMPLE_METHOD (PRIMITIVE (ICF_Tools.rem_dup_prems ctxt)))
› "Remove duplicate subgoals"
end
Theory Ord_Code_Preproc
section ‹Functrans simpset for Code Preprocessing›
theory Ord_Code_Preproc
imports Main ICF_Tools
begin
ML ‹
signature ORD_CODE_PREPROC = sig
val add: int * string * (theory -> thm -> thm) -> theory -> theory
val rem: string -> theory -> theory
val get: theory -> (int * string * (theory -> thm -> thm)) list
val setup: theory -> theory
val trace_enabled: bool Unsynchronized.ref
end
structure Ord_Code_Preproc: ORD_CODE_PREPROC = struct
val trace_enabled = Unsynchronized.ref false
val do_sort = sort (rev_order o int_ord o apply2 #1)
structure Data = Theory_Data (
type T = (int * string * (theory -> thm -> thm)) list
val empty = []
val extend = I
val merge = (op @) #> do_sort #> distinct ((=) o apply2 #2)
);
val get = Data.get
fun add tr = Data.map (fn l => do_sort (tr::l))
fun rem name = Data.map (filter (fn (_,n,_) => n <>name))
local
fun trace_ft ft thy thms = if !trace_enabled then let
val res = ft thy thms;
val (m1,m2) = case res of NONE => ("NF: ","")
| SOME thms => ("Preproc: REW: "," --> " ^ @{make_string} thms);
val _ = tracing (m1 ^ @{make_string} thms ^ m2);
in res end
else ft thy thms;
fun s_functrans ctxt thms =
let
val thy = Proof_Context.theory_of ctxt;
val trs = Data.get thy;
val process = fold (fn (_,_,tr) => fn thm => tr thy thm) trs;
val process' = fold (fn (_,name,tr) => fn thm => let
val thm' = tr thy thm;
val _ = if !trace_enabled andalso not (Thm.eq_thm (thm,thm')) then
tracing ("Preproc "^name^": " ^ @{make_string} thm ^ " --> " ^
@{make_string} thm')
else ();
in thm' end
) trs;
fun rew_ch acc ch [] = if ch then SOME acc else NONE
| rew_ch acc ch (thm::thms) = let
val thm' = process' thm;
val ch = ch orelse not (Thm.eq_thm (thm,thm'));
in rew_ch (thm'::acc) ch thms end;
in
rew_ch [] false thms
end;
in
val functrans = ("Functrans_ss.functrans",
Code_Preproc.simple_functrans ( (s_functrans)));
end;
val setup = Code_Preproc.add_functrans functrans;
end
signature OC_SIMPSET = sig
val get: theory -> simpset
val map: (simpset -> simpset) -> theory -> theory
val setup: theory -> theory
end
functor Oc_Simpset(val prio:int val name:string): OC_SIMPSET = struct
structure Data = Theory_Data (
type T = simpset
val empty = empty_ss
val extend = I
val merge = Raw_Simplifier.merge_ss
);
val get = Data.get
val map = Data.map
local
fun trans_fun thy thm = let
val ss = Proof_Context.init_global thy |> put_simpset (get thy)
in simplify ss thm end;
in
val setup = Ord_Code_Preproc.add (prio, name, trans_fun);
end
end
›
setup Ord_Code_Preproc.setup
end
Theory Record_Intf
section ‹Automation for Record Based Interfaces›
theory Record_Intf
imports Main ICF_Tools Ord_Code_Preproc
begin
text ‹The ICF uses coercions to simulate multiple inheritance of
operation records›
declare [[coercion_enabled]]
lemma icf_rec_def_rule: "⟦sel B = x; A≡B ⟧ ⟹ sel A = x " by auto
ML_val Context.mapping
ML ‹
signature RECORD_INTF = sig
val get_unf_ss: Context.generic -> simpset
val get_unf_thms: Context.generic -> thm list
val add_unf_thms: thm list -> Context.generic -> Context.generic
val add_unf_thms_global: thm list -> theory -> theory
val icf_rec_def: thm -> Context.generic -> Context.generic
val icf_rec_def_attr: attribute context_parser
val icf_locales_tac: Proof.context -> tactic
val setup: theory -> theory
end;
structure Record_Intf: RECORD_INTF = struct
open ICF_Tools;
structure Data = Generic_Data
(
type T = simpset;
val empty = HOL_basic_ss ;
val extend = I;
val merge = Raw_Simplifier.merge_ss;
);
structure CppSS = Oc_Simpset (
val prio = 2;
val name = "Record_Intf";
);
fun get_unf_ss context = Data.get context
val get_unf_thms = Data.get #> Raw_Simplifier.dest_ss #> #simps #> map #2
fun add_unf_thms thms context = let
val ctxt = Context.proof_of context
fun add ss = simpset_of (put_simpset ss ctxt addsimps thms)
in
context
|> Data.map add
|> Context.mapping (CppSS.map add) I
end
fun add_unf_thms_global thms = Context.theory_map (add_unf_thms thms);
fun gather_conv_thms ctxt typ = let
val thy = Proof_Context.theory_of ctxt
val infos = Record.dest_recTs typ
|> map fst |> map Long_Name.qualifier |> map (Record.the_info thy);
val cs = map #select_convs infos |> flat |> map (Thm.transfer thy);
val ds = map #defs infos @ map #simps infos |> flat
|> map (Thm.transfer thy);
in (cs,ds) end
fun gather_conv_thms_dt ctxt def_thm =
def_thm |> Thm.prop_of |> Logic.dest_equals |> fst
|> fastype_of |> gather_conv_thms ctxt;
local
fun unf_thms_of def_thm context = let
val ctxt = Context.proof_of context;
val def_thm = norm_def_thm def_thm;
val (conv_thms, simp_thms) = gather_conv_thms_dt ctxt def_thm;
val ss = put_simpset (get_unf_ss context) ctxt addsimps simp_thms
val unf_thms = conv_thms
|> map (
chead_of_thm
#> inst_meta_cong ctxt
#> (fn thm => thm OF [def_thm])
#> simplify ss
)
|> filter (not o Thm.is_reflexive);
in unf_thms end;
in
fun icf_rec_def def_thm context =
let
val unf_thms = unf_thms_of def_thm context;
val eqn_heads = the_list (try (fst o dest_Const o fst o strip_comb o fst o Logic.dest_equals
o Thm.plain_prop_of o Local_Defs.meta_rewrite_rule (Context.proof_of context)) def_thm)
in
context
|> add_unf_thms unf_thms
|> not (null eqn_heads) ? Context.mapping (fold Code.declare_aborting_global eqn_heads) I
end;
end
val icf_rec_def_attr : attribute context_parser =
Scan.succeed (Thm.declaration_attribute icf_rec_def);
fun icf_locales_tac ctxt = let
val ss = put_simpset (get_unf_ss (Context.Proof ctxt)) ctxt
val wits = Locale.get_witnesses ctxt
val thms = map (simplify ss) wits;
in ALLGOALS (TRY o (simp_tac ss THEN' resolve_tac ctxt thms)) end
fun setup_simprocs thy = let
val ctxt = Proof_Context.init_global thy
val ss = put_simpset HOL_basic_ss ctxt
addsimprocs [Record.simproc, Record.upd_simproc]
|> simpset_of
in
Data.map (K ss) (Context.Theory thy) |> Context.the_theory
end
val setup = Global_Theory.add_thms_dynamic
(@{binding icf_rec_unf}, get_unf_thms)
#> CppSS.setup
#> setup_simprocs;
end;
›
setup ‹Record_Intf.setup›
text ‹
Sets up unfolding for an operation record definition.
New operation record definitions should be declared as
‹[icf_rec_def]›.
›
attribute_setup icf_rec_def = ‹Record_Intf.icf_rec_def_attr›
"ICF: Setup unfolding for record definition"
method_setup icf_locales = ‹
Scan.succeed (fn ctxt => SIMPLE_METHOD (Record_Intf.icf_locales_tac ctxt))
› "ICF: Normalize records and discharge locale subgoals"
end
Theory Locale_Code
section ‹Code Generation from Locales›
theory Locale_Code
imports ICF_Tools Ord_Code_Preproc
begin
text ‹
Provides a simple mechanism to prepare code equations for
constants stemming from locale interpretations.
The usage pattern is as follows:
‹setup Locale_Code.checkpoint› is called before a series of
interpretations, and afterwards, ‹setup Locale_Code.prepare›
is called. Afterwards, the code generator will correctly recognize
expressions involving terms from the locale interpretation.
›
text ‹Tag to indicate pattern deletion›
definition LC_DEL :: "'a ⇒ unit" where "LC_DEL a ≡ ()"
ML ‹
signature LOCALE_CODE = sig
type pat_eq = cterm * thm list
val open_block: theory -> theory
val close_block: theory -> theory
val del_pat: cterm -> theory -> theory
val add_pat_eq: cterm -> thm list -> theory -> theory
val lc_decl_eq: thm list -> local_theory -> local_theory
val lc_decl_del: term -> local_theory -> local_theory
val setup: theory -> theory
val get_unf_ss: theory -> simpset
val tracing_enabled: bool Unsynchronized.ref
end
structure Locale_Code :LOCALE_CODE = struct
open ICF_Tools
val tracing_enabled = Unsynchronized.ref false;
type pat_eq = cterm * thm list
type block_data = {idx:int, del_pats: cterm list, add_pateqs: pat_eq list}
val closed_block = {idx = ~1, del_pats=[], add_pateqs=[]};
fun init_block idx = {idx = idx, del_pats=[], add_pateqs=[]};
fun is_open ({idx,...}:block_data) = idx <> ~1;
fun assert_open bd
= if is_open bd then () else error "Locale_Code: No open block";
fun assert_closed bd
= if is_open bd then error "Locale_Code: Block already open" else ();
fun merge_bd (bd1,bd2) = (
if is_open bd1 orelse is_open bd2 then
error "Locale_Code: Merge with open block"
else ();
closed_block
);
fun bd_add_del_pats ps {idx,del_pats,add_pateqs}
= {idx = idx, del_pats = ps@del_pats, add_pateqs = add_pateqs};
fun bd_add_add_pateqs pes {idx,del_pats,add_pateqs}
= {idx = idx, del_pats = del_pats, add_pateqs = pes@add_pateqs};
structure BlockData = Theory_Data (
type T = block_data
val empty = (closed_block)
val extend = I
val merge = merge_bd
);
structure FoldSSData = Oc_Simpset (
val prio = 5;
val name = "Locale_Code";
);
fun add_unf_thms thms thy = let
val ctxt = Proof_Context.init_global thy
val thms = map Thm.symmetric thms
in
FoldSSData.map (fn ss =>
put_simpset ss ctxt
|> sss_add thms
|> simpset_of
) thy
end
val get_unf_ss = FoldSSData.get;
fun match_fixed_head (pat,obj) = let
val inst = Thm.first_order_match (chead_of pat, chead_of obj);
val pat = Thm.instantiate_cterm inst pat;
val inst = Thm.first_order_match (pat, obj);
in inst end;
val matches_fixed_head = can match_fixed_head;
fun match_heads (pat,obj) = Thm.first_order_match (chead_of pat, chead_of obj);
val matches_heads = can match_heads;
val pat_nargs = Thm.term_of #> strip_comb #> #2 #> length;
fun norm_thm_pat (thm,pat) = let
val thm = norm_def_thm thm;
val na_pat = pat_nargs pat;
val lhs = Thm.lhs_of thm;
val na_lhs = pat_nargs lhs;
val lhs' = if na_lhs > na_pat then funpow (na_lhs - na_pat) Thm.dest_fun lhs
else lhs;
val inst = Thm.first_order_match (lhs',pat);
in Thm.instantiate inst thm end;
fun del_pat_matches cpat (epat,_) = if pat_nargs cpat = 0 then
matches_heads (cpat,epat)
else
matches_fixed_head (cpat,epat);
local
datatype action = ADD of (cterm * thm list)
| DEL of cterm
fun filter_pat_eq thy thms pat = let
val cpat = Thm.global_cterm_of thy pat;
in
if (pat_nargs cpat = 0) then NONE
else let
val thms' = fold
(fn thm => fn acc => case try norm_thm_pat (thm, cpat) of
NONE => acc | SOME thm => thm::acc
) thms [];
in case thms' of [] => NONE | _ => SOME (ADD (cpat,thms')) end
end;
fun process_actions acc [] = acc
| process_actions acc (ADD peq::acts) = process_actions (peq::acc) acts
| process_actions acc (DEL cpat::acts) = let
val acc' = filter (not o curry renames_cterm cpat o fst) acc;
val _ = if length acc = length acc' then
warning ("Locale_Code: LC_DEL without effect: "
^ @{make_string} cpat)
else ();
in process_actions acc' acts end;
fun pat_eqs_of_spec thy
{rough_classification = Spec_Rules.Equational _, terms = pats, rules = thms, ...} =
map_filter (filter_pat_eq thy thms) pats
| pat_eqs_of_spec thy
{rough_classification = Spec_Rules.Unknown, terms = [Const (@{const_name LC_DEL},_)$pat], ...} =
[(DEL (Thm.global_cterm_of thy pat))]
| pat_eqs_of_spec _ _ = [];
in
fun pat_eqs_of_specs thy specs = map (pat_eqs_of_spec thy) specs
|> flat |> rev |> process_actions [];
end;
fun is_proper_pat cpat = let
val pat = Thm.term_of cpat;
val (f,args) = strip_comb pat;
in
is_Const f
andalso args <> []
andalso not (is_Var (hd (rev args)))
end;
local
fun inst_name lthy pat = let
val (fname,params) = case strip_comb pat of
((Const (fname,_)),params) => (fname,params)
| _ => raise TERM ("inst_name: Expected pattern",[pat]);
fun pname (Const (n,_)) = Long_Name.base_name n
| pname (s$t) = pname s ^ "_" ^ pname t
| pname _ = Name.uu;
in
space_implode "_" (Long_Name.base_name fname::map pname params)
|> gen_variant (can (Proof_Context.read_const {proper = true, strict = false} lthy))
end;
in
fun inst_pat_eq (cpat,thms) =
wrap_lthy_result_global
(fn lthy => let
val ((inst,thms),lthy) = Variable.import true thms lthy;
val cpat = Thm.instantiate_cterm inst cpat;
val pat = Thm.term_of cpat;
val name = inst_name lthy pat;
val ((_,(_,def_thm)),lthy)
= Local_Theory.define ((Binding.name name,NoSyn),
((Binding.name (Thm.def_name name),[]),pat)) lthy;
val thms' = map (Local_Defs.fold lthy [def_thm]) thms;
in ((def_thm,thms'),lthy) end)
(fn m => fn (def_thm,thms') =>
(Morphism.thm m def_thm, map (Morphism.thm m) thms'))
#> (fn ((def_thm,thms'),thy) => let
val thy = thy
|> add_unf_thms [def_thm]
|> Code.declare_default_eqns_global (map (rpair true) thms');
in thy end)
end
fun new_specs thy = let
val bd = BlockData.get thy;
val _ = assert_open bd;
val ctxt = Proof_Context.init_global thy;
val srules = Spec_Rules.get ctxt;
val res = take (length srules - #idx bd) srules;
in res end
fun open_block thy = let
val bd = BlockData.get thy;
val _ = assert_closed bd;
val ctxt = Proof_Context.init_global thy;
val idx = length (Spec_Rules.get ctxt);
val thy = BlockData.map (K (init_block idx)) thy;
in thy end;
fun process_block bd thy = let
fun filter_del_pats cpat peqs = let
val peqs' = filter (not o del_pat_matches cpat) peqs
val _ = if length peqs = length peqs' then
warning ("Locale_Code: No pattern-eqs matching filter: " ^
@{make_string} cpat)
else ();
in peqs' end;
fun filter_add_pats (orig_pat,_) = forall (fn (add_pat,_) =>
not (renames_cterm (orig_pat,add_pat)))
(#add_pateqs bd);
val specs = new_specs thy;
val peqs = pat_eqs_of_specs thy specs
|> fold filter_del_pats (#del_pats bd)
|> filter filter_add_pats;
val peqs = peqs @ #add_pateqs bd;
val peqs = rev peqs;
val _ = if !tracing_enabled then
map (fn peq => (tracing (@{make_string} peq); ())) peqs
else [];
val thy = thy |> fold inst_pat_eq peqs;
in thy end;
fun close_block thy = let
val bd = BlockData.get thy;
val _ = assert_open bd;
val thy = process_block bd thy
|> BlockData.map (K closed_block);
in thy end;
fun del_pat cpat thy = let
val bd = BlockData.get thy;
val _ = assert_open bd;
val bd = bd_add_del_pats [cpat] bd;
val thy = BlockData.map (K bd) thy;
in thy end;
fun add_pat_eq cpat thms thy = let
val _ = is_proper_pat cpat
orelse raise CTERM ("add_pat_eq: Not a proper pattern",[cpat]);
fun ntp thm = case try norm_thm_pat (thm,cpat) of
NONE => raise THM ("add_pat_eq: Theorem does not match pattern",~1,[thm])
| SOME thm => thm;
val thms = map ntp thms;
val thy = BlockData.map (bd_add_add_pateqs [(cpat,thms)]) thy;
in thy end;
local
fun cpat_of_thm thm = let
fun strip ct = case Thm.term_of ct of
(_$Var _) => strip (Thm.dest_fun ct)
| _ => ct;
in
strip (Thm.lhs_of thm)
end;
fun adjust_length (cpat1,cpat2) = let
val n1 = cpat1 |> Thm.term_of |> strip_comb |> #2 |> length;
val n2 = cpat2 |> Thm.term_of |> strip_comb |> #2 |> length;
in
if n1>n2 then
(funpow (n1-n2) Thm.dest_fun cpat1, cpat2)
else
(cpat1, funpow (n2-n1) Thm.dest_fun cpat2)
end
fun find_match cpat cpat' = SOME (cpat,rename_cterm (cpat',cpat))
handle Pattern.MATCH => (case Thm.term_of cpat' of
_$_ => find_match (Thm.dest_fun cpat) (Thm.dest_fun cpat')
| _ => NONE
);
fun comp_head thms = case map norm_def_thm thms of
[] => NONE
| thm::thms => let
fun ch [] r = SOME r
| ch (thm::thms) (cpat,acc) = let
val cpat' = cpat_of_thm thm;
val (cpat,cpat') = adjust_length (cpat,cpat')
in case find_match cpat cpat' of NONE => NONE
| SOME (cpat,inst) =>
ch thms (cpat, Drule.instantiate_normalize inst thm :: acc)
end;
in ch thms (cpat_of_thm thm,[thm]) end;
in
fun lc_decl_eq thms lthy = case comp_head thms of
SOME (cpat,thms) => let
val _ = if !tracing_enabled then
tracing ("decl_eq: " ^ @{make_string} cpat ^ ": "
^ @{make_string} thms)
else ();
fun decl m = let
val cpat'::thms' = Morphism.fact m (Drule.mk_term cpat :: thms);
val cpat' = Drule.dest_term cpat';
in
Context.mapping
(BlockData.map (bd_add_add_pateqs [(cpat',thms')])) I
end
in
lthy |> Local_Theory.declaration {syntax = false, pervasive = false} decl
end
| NONE => raise THM ("Locale_Code.lc_decl_eq: No common pattern",~1,thms);
end;
fun lc_decl_del pat = let
val ty = fastype_of pat;
val dpat = Const (@{const_name LC_DEL},ty --> @{typ unit})$pat;
in
Spec_Rules.add Binding.empty Spec_Rules.Unknown [dpat] []
end
val setup = FoldSSData.setup;
end
›
setup Locale_Code.setup
attribute_setup lc_delete = ‹
Parse.and_list1' ICF_Tools.parse_cpat >>
(fn cpats => Thm.declaration_attribute (K
(Context.mapping (fold Locale_Code.del_pat cpats) I)))
› "Locale_Code: Delete patterns for current block"
attribute_setup lc_add = ‹
Parse.and_list1' (ICF_Tools.parse_cpat -- Attrib.thms) >>
(fn peqs => Thm.declaration_attribute (K
(Context.mapping (fold (uncurry Locale_Code.add_pat_eq) peqs) I)))
› "Locale_Code: Add pattern-eqs for current block"
end
Theory MapSpec
section ‹\isaheader{Specification of Maps}›
theory MapSpec
imports ICF_Spec_Base
begin
text_raw‹\label{thy:MapSpec}›
text ‹
This theory specifies map operations by means of mapping to
HOL's map type, i.e. @{typ "'k ⇀ 'v"}.
›
type_synonym ('k,'v,'s) map_α = "'s ⇒ 'k ⇀ 'v"
type_synonym ('k,'v,'s) map_invar = "'s ⇒ bool"
locale map =
fixes α :: "'s ⇒ 'u ⇀ 'v"
fixes invar :: "'s ⇒ bool"
locale map_no_invar = map +
assumes invar[simp, intro!]: "⋀s. invar s"
subsection "Basic Map Functions"
subsubsection "Empty Map"
type_synonym ('k,'v,'s) map_empty = "unit ⇒ 's"
locale map_empty = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes empty :: "unit ⇒ 's"
assumes empty_correct:
"α (empty ()) = Map.empty"
"invar (empty ())"
subsubsection "Lookup"
type_synonym ('k,'v,'s) map_lookup = "'k ⇒ 's ⇒ 'v option"
locale map_lookup = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes lookup :: "'u ⇒ 's ⇒ 'v option"
assumes lookup_correct:
"invar m ⟹ lookup k m = α m k"
subsubsection "Update"
type_synonym ('k,'v,'s) map_update = "'k ⇒ 'v ⇒ 's ⇒ 's"
locale map_update = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes update :: "'u ⇒ 'v ⇒ 's ⇒ 's"
assumes update_correct:
"invar m ⟹ α (update k v m) = (α m)(k ↦ v)"
"invar m ⟹ invar (update k v m)"
subsubsection "Disjoint Update"
type_synonym ('k,'v,'s) map_update_dj = "'k ⇒ 'v ⇒ 's ⇒ 's"
locale map_update_dj = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes update_dj :: "'u ⇒ 'v ⇒ 's ⇒ 's"
assumes update_dj_correct:
"⟦invar m; k∉dom (α m)⟧ ⟹ α (update_dj k v m) = (α m)(k ↦ v)"
"⟦invar m; k∉dom (α m)⟧ ⟹ invar (update_dj k v m)"
subsubsection "Delete"
type_synonym ('k,'v,'s) map_delete = "'k ⇒ 's ⇒ 's"
locale map_delete = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes delete :: "'u ⇒ 's ⇒ 's"
assumes delete_correct:
"invar m ⟹ α (delete k m) = (α m) |` (-{k})"
"invar m ⟹ invar (delete k m)"
subsubsection "Add"
type_synonym ('k,'v,'s) map_add = "'s ⇒ 's ⇒ 's"
locale map_add = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes add :: "'s ⇒ 's ⇒ 's"
assumes add_correct:
"invar m1 ⟹ invar m2 ⟹ α (add m1 m2) = α m1 ++ α m2"
"invar m1 ⟹ invar m2 ⟹ invar (add m1 m2)"
type_synonym ('k,'v,'s) map_add_dj = "'s ⇒ 's ⇒ 's"
locale map_add_dj = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes add_dj :: "'s ⇒ 's ⇒ 's"
assumes add_dj_correct:
"⟦invar m1; invar m2; dom (α m1) ∩ dom (α m2) = {}⟧ ⟹ α (add_dj m1 m2) = α m1 ++ α m2"
"⟦invar m1; invar m2; dom (α m1) ∩ dom (α m2) = {} ⟧ ⟹ invar (add_dj m1 m2)"
subsubsection "Emptiness Check"
type_synonym ('k,'v,'s) map_isEmpty = "'s ⇒ bool"
locale map_isEmpty = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes isEmpty :: "'s ⇒ bool"
assumes isEmpty_correct : "invar m ⟹ isEmpty m ⟷ α m = Map.empty"
subsubsection "Singleton Maps"
type_synonym ('k,'v,'s) map_sng = "'k ⇒ 'v ⇒ 's"
locale map_sng = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes sng :: "'u ⇒ 'v ⇒ 's"
assumes sng_correct :
"α (sng k v) = [k ↦ v]"
"invar (sng k v)"
type_synonym ('k,'v,'s) map_isSng = "'s ⇒ bool"
locale map_isSng = map +
constrains α :: "'s ⇒ 'k ⇀ 'v"
fixes isSng :: "'s ⇒ bool"
assumes isSng_correct:
"invar s ⟹ isSng s ⟷ (∃k v. α s = [k ↦ v])"
begin
lemma isSng_correct_exists1 :
"invar s ⟹ (isSng s ⟷ (∃!k. ∃v. (α s k = Some v)))"
apply (auto simp add: isSng_correct split: if_split_asm)
apply (rule_tac x=k in exI)
apply (rule_tac x=v in exI)
apply (rule ext)
apply (case_tac "α s x")
apply auto
apply force
done
lemma isSng_correct_card :
"invar s ⟹ (isSng s ⟷ (card (dom (α s)) = 1))"
by (auto simp add: isSng_correct card_Suc_eq dom_eq_singleton_conv)
end
subsubsection "Finite Maps"
locale finite_map = map +
assumes finite[simp, intro!]: "invar m ⟹ finite (dom (α m))"
subsubsection "Size"
type_synonym ('k,'v,'s) map_size = "'s ⇒ nat"
locale map_size = finite_map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes size :: "'s ⇒ nat"
assumes size_correct: "invar s ⟹ size s = card (dom (α s))"
type_synonym ('k,'v,'s) map_size_abort = "nat ⇒ 's ⇒ nat"
locale map_size_abort = finite_map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes size_abort :: "nat ⇒ 's ⇒ nat"
assumes size_abort_correct: "invar s ⟹ size_abort m s = min m (card (dom (α s)))"
subsubsection "Iterators"
text ‹
An iteration combinator over a map applies a function to a state for each
map entry, in arbitrary order.
Proving of properties is done by invariant reasoning.
An iterator can also contain a continuation condition. Iteration is
interrupted if the condition becomes false.
›
type_synonym ('k,'v,'s) map_list_it
= "'s ⇒ ('k×'v,('k×'v) list) set_iterator"
locale poly_map_iteratei_defs =
fixes list_it :: "'s ⇒ ('u×'v,('u×'v) list) set_iterator"
begin
definition iteratei :: "'s ⇒ ('u×'v,'σ) set_iterator"
where "iteratei S ≡ it_to_it (list_it S)"
abbreviation "iterate m ≡ iteratei m (λ_. True)"
end
locale poly_map_iteratei =
finite_map + poly_map_iteratei_defs list_it
for list_it :: "'s ⇒ ('u×'v,('u×'v) list) set_iterator" +
constrains α :: "'s ⇒ 'u ⇀ 'v"
assumes list_it_correct: "invar m ⟹ map_iterator (list_it m) (α m)"
begin
lemma iteratei_correct: "invar S ⟹ map_iterator (iteratei S) (α S)"
unfolding iteratei_def
apply (rule it_to_it_correct)
by (rule list_it_correct)
lemma pi_iteratei[icf_proper_iteratorI]:
"proper_it (iteratei S) (iteratei S)"
unfolding iteratei_def
by (intro icf_proper_iteratorI)
lemma iteratei_rule_P:
assumes "invar m"
and I0: "I (map_to_set (α m)) σ0"
and IP: "!!k v it σ. ⟦ c σ; (k,v) ∈ it; it ⊆ map_to_set (α m); I it σ ⟧
⟹ I (it - {(k,v)}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ map_to_set (α m); it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (iteratei m c f σ0)"
apply (rule set_iterator_rule_P[OF iteratei_correct])
apply fact
apply fact
apply (case_tac x, simp add: IP)
apply fact
apply fact
done
lemma iteratei_rule_insert_P:
assumes "invar m"
and "I {} σ0"
and "!!k v it σ. ⟦ c σ; (k,v) ∈ (map_to_set (α m) - it);
it ⊆ map_to_set (α m); I it σ ⟧
⟹ I (insert (k,v) it) (f (k, v) σ)"
and "!!σ. I (map_to_set (α m)) σ ⟹ P σ"
and "!!σ it. ⟦ it ⊆ map_to_set (α m); it ≠ map_to_set (α m);
¬ (c σ);
I it σ ⟧ ⟹ P σ"
shows "P (iteratei m c f σ0)"
apply (rule set_iterator_rule_insert_P[OF iteratei_correct])
apply fact
apply fact
apply (case_tac x, simp add: assms)
apply fact
apply fact
done
lemma iterate_rule_P:
assumes "invar m"
and I0: "I (map_to_set (α m)) σ0"
and IP: "!!k v it σ. ⟦ (k,v) ∈ it; it ⊆ map_to_set (α m); I it σ ⟧
⟹ I (it - {(k,v)}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
shows "P (iterate m f σ0)"
apply (rule iteratei_rule_P)
apply fact
apply (rule I0)
apply (rule IP, assumption+) []
apply (rule IF, assumption)
apply simp
done
lemma iterate_rule_insert_P:
assumes "invar m"
and I0: "I {} σ0"
and "!!k v it σ. ⟦ (k,v) ∈ (map_to_set (α m) - it);
it ⊆ map_to_set (α m); I it σ ⟧
⟹ I (insert (k,v) it) (f (k, v) σ)"
and "!!σ. I (map_to_set (α m)) σ ⟹ P σ"
shows "P (iterate m f σ0)"
apply (rule iteratei_rule_insert_P)
apply fact
apply (rule I0)
apply (rule assms, assumption+) []
apply (rule assms, assumption)
apply simp
done
lemma old_iteratei_rule_P:
assumes "invar m"
and I0: "I (dom (α m)) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom (α m); it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (iteratei m c f σ0)"
using assms
by (rule map_iterator_rule_P[OF iteratei_correct])
lemma old_iteratei_rule_insert_P:
assumes "invar m"
and "I {} σ0"
and "!!k v it σ. ⟦ c σ; k ∈ (dom (α m) - it); α m k = Some v;
it ⊆ dom (α m); I it σ ⟧
⟹ I (insert k it) (f (k, v) σ)"
and "!!σ. I (dom (α m)) σ ⟹ P σ"
and "!!σ it. ⟦ it ⊆ dom (α m); it ≠ dom (α m);
¬ (c σ);
I it σ ⟧ ⟹ P σ"
shows "P (iteratei m c f σ0)"
using assms by (rule map_iterator_rule_insert_P[OF iteratei_correct])
lemma old_iterate_rule_P:
"⟦
invar m;
I (dom (α m)) σ0;
!!k v it σ. ⟦ k ∈ it; α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (it - {k}) (f (k, v) σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (iterate m f σ0)"
using old_iteratei_rule_P [of m I σ0 "λ_. True" f P]
by blast
lemma old_iterate_rule_insert_P:
"⟦
invar m;
I {} σ0;
!!k v it σ. ⟦ k ∈ (dom (α m) - it); α m k = Some v;
it ⊆ dom (α m); I it σ ⟧
⟹ I (insert k it) (f (k, v) σ);
!!σ. I (dom (α m)) σ ⟹ P σ
⟧ ⟹ P (iteratei m (λ_. True) f σ0)"
using old_iteratei_rule_insert_P [of m I σ0 "λ_. True" f P]
by blast
end
subsubsection "Bounded Quantification"
type_synonym ('k,'v,'s) map_ball = "'s ⇒ ('k × 'v ⇒ bool) ⇒ bool"
locale map_ball = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes ball :: "'s ⇒ ('u × 'v ⇒ bool) ⇒ bool"
assumes ball_correct: "invar m ⟹ ball m P ⟷ (∀u v. α m u = Some v ⟶ P (u, v))"
type_synonym ('k,'v,'s) map_bex = "'s ⇒ ('k × 'v ⇒ bool) ⇒ bool"
locale map_bex = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes bex :: "'s ⇒ ('u × 'v ⇒ bool) ⇒ bool"
assumes bex_correct:
"invar m ⟹ bex m P ⟷ (∃u v. α m u = Some v ∧ P (u, v))"
subsubsection "Selection of Entry"
type_synonym ('k,'v,'s,'r) map_sel = "'s ⇒ ('k × 'v ⇒ 'r option) ⇒ 'r option"
locale map_sel = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes sel :: "'s ⇒ ('u × 'v ⇒ 'r option) ⇒ 'r option"
assumes selE:
"⟦ invar m; α m u = Some v; f (u, v) = Some r;
!!u v r. ⟦ sel m f = Some r; α m u = Some v; f (u, v) = Some r ⟧ ⟹ Q
⟧ ⟹ Q"
assumes selI:
"⟦ invar m; ∀u v. α m u = Some v ⟶ f (u, v) = None ⟧ ⟹ sel m f = None"
begin
lemma sel_someE:
"⟦ invar m; sel m f = Some r;
!!u v. ⟦ α m u = Some v; f (u, v) = Some r ⟧ ⟹ P
⟧ ⟹ P"
apply (cases "∃u v r. α m u = Some v ∧ f (u, v) = Some r")
apply safe
apply (erule_tac u=u and v=v and r=ra in selE)
apply assumption
apply assumption
apply simp
apply (auto)
apply (drule (1) selI)
apply simp
done
lemma sel_noneD: "⟦invar m; sel m f = None; α m u = Some v⟧ ⟹ f (u, v) = None"
apply (rule ccontr)
apply simp
apply (erule exE)
apply (erule_tac f=f and u=u and v=v and r=y in selE)
apply auto
done
end
lemma map_sel_altI:
assumes S1:
"!!s f r P. ⟦ invar s; sel s f = Some r;
!!u v. ⟦α s u = Some v; f (u, v) = Some r⟧ ⟹ P
⟧ ⟹ P"
assumes S2:
"!!s f u v. ⟦invar s; sel s f = None; α s u = Some v⟧ ⟹ f (u, v) = None"
shows "map_sel α invar sel"
proof -
show ?thesis
apply (unfold_locales)
apply (case_tac "sel m f")
apply (force dest: S2)
apply (force elim: S1)
apply (case_tac "sel m f")
apply assumption
apply (force elim: S1)
done
qed
subsubsection "Selection of Entry (without mapping)"
type_synonym ('k,'v,'s) map_sel' = "'s ⇒ ('k × 'v ⇒ bool) ⇒ ('k×'v) option"
locale map_sel' = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes sel' :: "'s ⇒ ('u × 'v ⇒ bool) ⇒ ('u×'v) option"
assumes sel'E:
"⟦ invar m; α m u = Some v; P (u, v);
!!u v. ⟦ sel' m P = Some (u,v); α m u = Some v; P (u, v)⟧ ⟹ Q
⟧ ⟹ Q"
assumes sel'I:
"⟦ invar m; ∀u v. α m u = Some v ⟶ ¬ P (u, v) ⟧ ⟹ sel' m P = None"
begin
lemma sel'_someE:
"⟦ invar m; sel' m P = Some (u,v);
!!u v. ⟦ α m u = Some v; P (u, v) ⟧ ⟹ thesis
⟧ ⟹ thesis"
apply (cases "∃u v. α m u = Some v ∧ P (u, v)")
apply safe
apply (erule_tac u=ua and v=va in sel'E)
apply assumption
apply assumption
apply simp
apply (auto)
apply (drule (1) sel'I)
apply simp
done
lemma sel'_noneD: "⟦invar m; sel' m P = None; α m u = Some v⟧ ⟹ ¬ P (u, v)"
apply (rule ccontr)
apply simp
apply (erule (2) sel'E[where P=P])
apply auto
done
lemma sel'_SomeD:
"⟦ sel' m P = Some (u, v); invar m ⟧ ⟹ α m u = Some v ∧ P (u, v)"
apply(cases "∃u' v'. α m u' = Some v' ∧ P (u', v')")
apply clarsimp
apply(erule (2) sel'E[where P=P])
apply simp
apply(clarsimp)
apply(drule (1) sel'I)
apply simp
done
end
subsubsection "Map to List Conversion"
type_synonym ('k,'v,'s) map_to_list = "'s ⇒ ('k×'v) list"
locale map_to_list = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes to_list :: "'s ⇒ ('u×'v) list"
assumes to_list_correct:
"invar m ⟹ map_of (to_list m) = α m"
"invar m ⟹ distinct (map fst (to_list m))"
subsubsection "List to Map Conversion"
type_synonym ('k,'v,'s) list_to_map = "('k×'v) list ⇒ 's"
locale list_to_map = map +
constrains α :: "'s ⇒ 'u ⇀ 'v"
fixes to_map :: "('u×'v) list ⇒ 's"
assumes to_map_correct:
"α (to_map l) = map_of l"
"invar (to_map l)"
subsubsection "Image of a Map"
text ‹This locale allows to apply a function to both the keys and
the values of a map while at the same time filtering entries.›
definition transforms_to_unique_keys ::
"('u1 ⇀ 'v1) ⇒ ('u1 × 'v1 ⇀ ('u2 × 'v2)) ⇒ bool"
where
"transforms_to_unique_keys m f ≡ (∀k1 k2 v1 v2 k' v1' v2'. (
m k1 = Some v1 ∧
m k2 = Some v2 ∧
f (k1, v1) = Some (k', v1') ∧
f (k2, v2) = Some (k', v2')) -->
(k1 = k2))"
type_synonym ('k1,'v1,'m1,'k2,'v2,'m2) map_image_filter
= "('k1 × 'v1 ⇒ ('k2 × 'v2) option) ⇒ 'm1 ⇒ 'm2"
locale map_image_filter = m1: map α1 invar1 + m2: map α2 invar2
for α1 :: "'m1 ⇒ 'u1 ⇀ 'v1" and invar1
and α2 :: "'m2 ⇒ 'u2 ⇀ 'v2" and invar2
+
fixes map_image_filter :: "('u1 × 'v1 ⇒ ('u2 × 'v2) option) ⇒ 'm1 ⇒ 'm2"
assumes map_image_filter_correct_aux1:
"⋀k' v'.
⟦invar1 m; transforms_to_unique_keys (α1 m) f⟧ ⟹
(invar2 (map_image_filter f m) ∧
((α2 (map_image_filter f m) k' = Some v') ⟷
(∃k v. (α1 m k = Some v) ∧ f (k, v) = Some (k', v'))))"
begin
lemma map_image_filter_correct_aux2 :
assumes "invar1 m"
and "transforms_to_unique_keys (α1 m) f"
shows "(α2 (map_image_filter f m) k' = None) ⟷
(∀k v v'. α1 m k = Some v ⟶ f (k, v) ≠ Some (k', v'))"
proof -
note map_image_filter_correct_aux1 [OF assms]
have Some_eq: "⋀v'. (α2 (map_image_filter f m) k' = Some v') =
(∃k v. α1 m k = Some v ∧ f (k, v) = Some (k', v'))"
by (simp add: map_image_filter_correct_aux1 [OF assms])
have intro_some: "(α2 (map_image_filter f m) k' = None) ⟷
(∀v'. α2 (map_image_filter f m) k' ≠ Some v')" by auto
from intro_some Some_eq show ?thesis by auto
qed
lemmas map_image_filter_correct =
conjunct1 [OF map_image_filter_correct_aux1]
conjunct2 [OF map_image_filter_correct_aux1]
map_image_filter_correct_aux2
end
text ‹Most of the time the mapping function is only applied to values. Then,
the precondition disapears.›
type_synonym ('k,'v1,'m1,'k2,'v2,'m2) map_value_image_filter
= "('k ⇒ 'v1 ⇒ 'v2 option) ⇒ 'm1 ⇒ 'm2"
locale map_value_image_filter = m1: map α1 invar1 + m2: map α2 invar2
for α1 :: "'m1 ⇒ 'u ⇀ 'v1" and invar1
and α2 :: "'m2 ⇒ 'u ⇀ 'v2" and invar2
+
fixes map_value_image_filter :: "('u ⇒ 'v1 ⇒ 'v2 option) ⇒ 'm1 ⇒ 'm2"
assumes map_value_image_filter_correct_aux:
"invar1 m ⟹
invar2 (map_value_image_filter f m) ∧
(α2 (map_value_image_filter f m) =
(λk. Option.bind (α1 m k) (f k)))"
begin
lemmas map_value_image_filter_correct =
conjunct1[OF map_value_image_filter_correct_aux]
conjunct2[OF map_value_image_filter_correct_aux]
lemma map_value_image_filter_correct_alt :
"invar1 m ⟹
invar2 (map_value_image_filter f m)"
"invar1 m ⟹
(α2 (map_value_image_filter f m) k = Some v') ⟷
(∃v. (α1 m k = Some v) ∧ f k v = Some v')"
"invar1 m ⟹
(α2 (map_value_image_filter f m) k = None) ⟷
(∀v. (α1 m k = Some v) --> f k v = None)"
proof -
assume invar_m : "invar1 m"
note aux = map_value_image_filter_correct_aux [OF invar_m]
from aux show "invar2 (map_value_image_filter f m)" by simp
from aux show "(α2 (map_value_image_filter f m) k = Some v') ⟷
(∃v. (α1 m k = Some v) ∧ f k v = Some v')"
by (cases "α1 m k", simp_all)
from aux show "(α2 (map_value_image_filter f m) k = None) ⟷
(∀v. (α1 m k = Some v) --> f k v = None)"
by (cases "α1 m k", simp_all)
qed
end
type_synonym ('k,'v,'m1,'m2) map_restrict = "('k × 'v ⇒ bool) ⇒ 'm1 ⇒ 'm2"
locale map_restrict = m1: map α1 invar1 + m2: map α2 invar2
for α1 :: "'m1 ⇒ 'u ⇀ 'v" and invar1
and α2 :: "'m2 ⇒ 'u ⇀ 'v" and invar2
+
fixes restrict :: "('u × 'v ⇒ bool) ⇒ 'm1 ⇒ 'm2"
assumes restrict_correct_aux1 :
"invar1 m ⟹ α2 (restrict P m) = α1 m |` {k. ∃v. α1 m k = Some v ∧ P (k, v)}"
"invar1 m ⟹ invar2 (restrict P m)"
begin
lemma restrict_correct_aux2 :
"invar1 m ⟹ α2 (restrict (λ(k,_). P k) m) = α1 m |` {k. P k}"
proof -
assume invar_m : "invar1 m"
have "α1 m |` {k. (∃v. α1 m k = Some v) ∧ P k} = α1 m |` {k. P k}"
(is "α1 m |` ?A1 = α1 m |` ?A2")
proof
fix k
show "(α1 m |` ?A1) k = (α1 m |` ?A2) k"
proof (cases "k ∈ ?A2")
case False thus ?thesis by simp
next
case True
hence P_k : "P k" by simp
show ?thesis
by (cases "α1 m k", simp_all add: P_k)
qed
qed
with invar_m show "α2 (restrict (λ(k, _). P k) m) = α1 m |` {k. P k}"
by (simp add: restrict_correct_aux1)
qed
lemmas restrict_correct =
restrict_correct_aux1
restrict_correct_aux2
end
subsection "Ordered Maps"
locale ordered_map = map α invar
for α :: "'s ⇒ ('u::linorder) ⇀ 'v" and invar
locale ordered_finite_map = finite_map α invar + ordered_map α invar
for α :: "'s ⇒ ('u::linorder) ⇀ 'v" and invar
subsubsection ‹Ordered Iteration›
locale poly_map_iterateoi_defs =
fixes olist_it :: "'s ⇒ ('u×'v,('u×'v) list) set_iterator"
begin
definition iterateoi :: "'s ⇒ ('u×'v,'σ) set_iterator"
where "iterateoi S ≡ it_to_it (olist_it S)"
abbreviation "iterateo m ≡ iterateoi m (λ_. True)"
end
locale poly_map_iterateoi =
finite_map α invar + poly_map_iterateoi_defs list_ordered_it
for α :: "'s ⇒ ('u::linorder) ⇀ 'v"
and invar
and list_ordered_it :: "'s ⇒ ('u×'v,('u×'v) list) set_iterator" +
assumes list_ordered_it_correct: "invar m
⟹ map_iterator_linord (list_ordered_it m) (α m)"
begin
lemma iterateoi_correct: "invar S ⟹ map_iterator_linord (iterateoi S) (α S)"
unfolding iterateoi_def
apply (rule it_to_it_map_linord_correct)
by (rule list_ordered_it_correct)
lemma pi_iterateoi[icf_proper_iteratorI]:
"proper_it (iterateoi S) (iterateoi S)"
unfolding iterateoi_def
by (intro icf_proper_iteratorI)
lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
c σ;
k ∈ it;
α m k = Some v;
it ⊆ dom (α m);
I it σ;
⋀j. j∈it ⟹ k≤j;
⋀j. j∈dom (α m) - it ⟹ j≤k
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ dom (α m);
it ≠ {};
¬ c σ;
I it σ;
⋀k j. ⟦k∈it; j∈dom (α m) - it⟧ ⟹ j≤k
⟧ ⟹ P σ"
shows "P (iterateoi m c f σ0)"
using assms by (rule map_iterator_linord_rule_P[OF iterateoi_correct])
lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
k ∈ it;
α m k = Some v;
it ⊆ dom (α m);
I it σ;
⋀j. j∈it ⟹ k≤j;
⋀j. j∈dom (α m) - it ⟹ j≤k
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (iterateo m f σ0)"
using assms
map_iterator_linord_rule_P[OF iterateoi_correct, of m I σ0 "λ_. True" f P]
by blast
end
type_synonym ('k,'v,'s) map_list_rev_it
= "'s ⇒ ('k×'v,('k×'v) list) set_iterator"
locale poly_map_rev_iterateoi_defs =
fixes list_rev_it :: "'s ⇒ ('u×'v,('u×'v) list) set_iterator"
begin
definition rev_iterateoi :: "'s ⇒ ('u×'v,'σ) set_iterator"
where "rev_iterateoi S ≡ it_to_it (list_rev_it S)"
abbreviation "rev_iterateo m ≡ rev_iterateoi m (λ_. True)"
abbreviation "reverse_iterateoi ≡ rev_iterateoi"
abbreviation "reverse_iterateo ≡ rev_iterateo"
end
locale poly_map_rev_iterateoi =
finite_map α invar + poly_map_rev_iterateoi_defs list_rev_it
for α :: "'s ⇒ ('u::linorder) ⇀ 'v"
and invar
and list_rev_it :: "'s ⇒ ('u×'v,('u×'v) list) set_iterator" +
assumes list_rev_it_correct:
"invar m ⟹ map_iterator_rev_linord (list_rev_it m) (α m)"
begin
lemma rev_iterateoi_correct:
"invar S ⟹ map_iterator_rev_linord (rev_iterateoi S) (α S)"
unfolding rev_iterateoi_def
apply (rule it_to_it_map_rev_linord_correct)
by (rule list_rev_it_correct)
lemma pi_rev_iterateoi[icf_proper_iteratorI]:
"proper_it (rev_iterateoi S) (rev_iterateoi S)"
unfolding rev_iterateoi_def
by (intro icf_proper_iteratorI)
lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
c σ;
k ∈ it;
α m k = Some v;
it ⊆ dom (α m);
I it σ;
⋀j. j∈it ⟹ k≥j;
⋀j. j∈dom (α m) - it ⟹ j≥k
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ dom (α m);
it ≠ {};
¬ c σ;
I it σ;
⋀k j. ⟦k∈it; j∈dom (α m) - it⟧ ⟹ j≥k
⟧ ⟹ P σ"
shows "P (rev_iterateoi m c f σ0)"
using assms by (rule map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct])
lemma rev_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
k ∈ it;
α m k = Some v;
it ⊆ dom (α m);
I it σ;
⋀j. j∈it ⟹ k≥j;
⋀j. j∈dom (α m) - it ⟹ j≥k
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (rev_iterateo m f σ0)"
using assms
map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct,
of m I σ0 "λ_. True" f P]
by blast
end
subsubsection ‹Minimal and Maximal Elements›
type_synonym ('k,'v,'s) map_min
= "'s ⇒ ('k × 'v ⇒ bool) ⇒ ('k × 'v) option"
locale map_min = ordered_map +
constrains α :: "'s ⇒ 'u::linorder ⇀ 'v"
fixes min :: "'s ⇒ ('u × 'v ⇒ bool) ⇒ ('u × 'v) option"
assumes min_correct:
"⟦ invar s; rel_of (α s) P ≠ {} ⟧ ⟹ min s P ∈ Some ` rel_of (α s) P"
"⟦ invar s; (k,v) ∈ rel_of (α s) P ⟧ ⟹ fst (the (min s P)) ≤ k"
"⟦ invar s; rel_of (α s) P = {} ⟧ ⟹ min s P = None"
begin
lemma minE:
assumes A: "invar s" "rel_of (α s) P ≠ {}"
obtains k v where
"min s P = Some (k,v)" "(k,v)∈rel_of (α s) P" "∀(k',v')∈rel_of (α s) P. k ≤ k'"
proof -
from min_correct(1)[OF A] have MIS: "min s P ∈ Some ` rel_of (α s) P" .
then obtain k v where KV: "min s P = Some (k,v)" "(k,v)∈rel_of (α s) P"
by auto
show thesis
apply (rule that[OF KV])
apply (clarify)
apply (drule min_correct(2)[OF ‹invar s›])
apply (simp add: KV(1))
done
qed
lemmas minI = min_correct(3)
lemma min_Some:
"⟦ invar s; min s P = Some (k,v) ⟧ ⟹ (k,v)∈rel_of (α s) P"
"⟦ invar s; min s P = Some (k,v); (k',v')∈rel_of (α s) P ⟧ ⟹ k≤k'"
apply -
apply (cases "rel_of (α s) P = {}")
apply (drule (1) min_correct(3))
apply simp
apply (erule (1) minE)
apply auto [1]
apply (drule (1) min_correct(2))
apply auto
done
lemma min_None:
"⟦ invar s; min s P = None ⟧ ⟹ rel_of (α s) P = {}"
apply (cases "rel_of (α s) P = {}")
apply simp
apply (drule (1) min_correct(1))
apply auto
done
end
type_synonym ('k,'v,'s) map_max
= "'s ⇒ ('k × 'v ⇒ bool) ⇒ ('k × 'v) option"
locale map_max = ordered_map +
constrains α :: "'s ⇒ 'u::linorder ⇀ 'v"
fixes max :: "'s ⇒ ('u × 'v ⇒ bool) ⇒ ('u × 'v) option"
assumes max_correct:
"⟦ invar s; rel_of (α s) P ≠ {} ⟧ ⟹ max s P ∈ Some ` rel_of (α s) P"
"⟦ invar s; (k,v) ∈ rel_of (α s) P ⟧ ⟹ fst (the (max s P)) ≥ k"
"⟦ invar s; rel_of (α s) P = {} ⟧ ⟹ max s P = None"
begin
lemma maxE:
assumes A: "invar s" "rel_of (α s) P ≠ {}"
obtains k v where
"max s P = Some (k,v)" "(k,v)∈rel_of (α s) P" "∀(k',v')∈rel_of (α s) P. k ≥ k'"
proof -
from max_correct(1)[OF A] have MIS: "max s P ∈ Some ` rel_of (α s) P" .
then obtain k v where KV: "max s P = Some (k,v)" "(k,v)∈rel_of (α s) P"
by auto
show thesis
apply (rule that[OF KV])
apply (clarify)
apply (drule max_correct(2)[OF ‹invar s›])
apply (simp add: KV(1))
done
qed
lemmas maxI = max_correct(3)
lemma max_Some:
"⟦ invar s; max s P = Some (k,v) ⟧ ⟹ (k,v)∈rel_of (α s) P"
"⟦ invar s; max s P = Some (k,v); (k',v')∈rel_of (α s) P ⟧ ⟹ k≥k'"
apply -
apply (cases "rel_of (α s) P = {}")
apply (drule (1) max_correct(3))
apply simp
apply (erule (1) maxE)
apply auto [1]
apply (drule (1) max_correct(2))
apply auto
done
lemma max_None:
"⟦ invar s; max s P = None ⟧ ⟹ rel_of (α s) P = {}"
apply (cases "rel_of (α s) P = {}")
apply simp
apply (drule (1) max_correct(1))
apply auto
done
end
subsubsection "Conversion to List"
type_synonym ('k,'v,'s) map_to_sorted_list
= "'s ⇒ ('k × 'v) list"
locale map_to_sorted_list = ordered_map +
constrains α :: "'s ⇒ 'u::linorder ⇀ 'v"
fixes to_sorted_list :: "'s ⇒ ('u×'v) list"
assumes to_sorted_list_correct:
"invar m ⟹ map_of (to_sorted_list m) = α m"
"invar m ⟹ distinct (map fst (to_sorted_list m))"
"invar m ⟹ sorted (map fst (to_sorted_list m))"
type_synonym ('k,'v,'s) map_to_rev_list
= "'s ⇒ ('k × 'v) list"
locale map_to_rev_list = ordered_map +
constrains α :: "'s ⇒ 'u::linorder ⇀ 'v"
fixes to_rev_list :: "'s ⇒ ('u×'v) list"
assumes to_rev_list_correct:
"invar m ⟹ map_of (to_rev_list m) = α m"
"invar m ⟹ distinct (map fst (to_rev_list m))"
"invar m ⟹ sorted (rev (map fst (to_rev_list m)))"
subsection "Record Based Interface"
record ('k,'v,'s) map_ops =
map_op_α :: "('k,'v,'s) map_α"
map_op_invar :: "('k,'v,'s) map_invar"
map_op_empty :: "('k,'v,'s) map_empty"
map_op_lookup :: "('k,'v,'s) map_lookup"
map_op_update :: "('k,'v,'s) map_update"
map_op_update_dj :: "('k,'v,'s) map_update_dj"
map_op_delete :: "('k,'v,'s) map_delete"
map_op_list_it :: "('k,'v,'s) map_list_it"
map_op_sng :: "('k,'v,'s) map_sng"
map_op_restrict :: "('k,'v,'s,'s) map_restrict"
map_op_add :: "('k,'v,'s) map_add"
map_op_add_dj :: "('k,'v,'s) map_add_dj"
map_op_isEmpty :: "('k,'v,'s) map_isEmpty"
map_op_isSng :: "('k,'v,'s) map_isSng"
map_op_ball :: "('k,'v,'s) map_ball"
map_op_bex :: "('k,'v,'s) map_bex"
map_op_size :: "('k,'v,'s) map_size"
map_op_size_abort :: "('k,'v,'s) map_size_abort"
map_op_sel :: "('k,'v,'s) map_sel'"
map_op_to_list :: "('k,'v,'s) map_to_list"
map_op_to_map :: "('k,'v,'s) list_to_map"
locale StdMapDefs = poly_map_iteratei_defs "map_op_list_it ops"
for ops :: "('k,'v,'s,'more) map_ops_scheme"
begin
abbreviation α where "α == map_op_α ops"
abbreviation invar where "invar == map_op_invar ops"
abbreviation empty where "empty == map_op_empty ops"
abbreviation lookup where "lookup == map_op_lookup ops"
abbreviation update where "update == map_op_update ops"
abbreviation update_dj where "update_dj == map_op_update_dj ops"
abbreviation delete where "delete == map_op_delete ops"
abbreviation list_it where "list_it == map_op_list_it ops"
abbreviation sng where "sng == map_op_sng ops"
abbreviation restrict where "restrict == map_op_restrict ops"
abbreviation add where "add == map_op_add ops"
abbreviation add_dj where "add_dj == map_op_add_dj ops"
abbreviation isEmpty where "isEmpty == map_op_isEmpty ops"
abbreviation isSng where "isSng == map_op_isSng ops"
abbreviation ball where "ball == map_op_ball ops"
abbreviation bex where "bex == map_op_bex ops"
abbreviation size where "size == map_op_size ops"
abbreviation size_abort where "size_abort == map_op_size_abort ops"
abbreviation sel where "sel == map_op_sel ops"
abbreviation to_list where "to_list == map_op_to_list ops"
abbreviation to_map where "to_map == map_op_to_map ops"
end
locale StdMap = StdMapDefs ops +
map α invar +
map_empty α invar empty +
map_lookup α invar lookup +
map_update α invar update +
map_update_dj α invar update_dj +
map_delete α invar delete +
poly_map_iteratei α invar list_it +
map_sng α invar sng +
map_restrict α invar α invar restrict +
map_add α invar add +
map_add_dj α invar add_dj +
map_isEmpty α invar isEmpty +
map_isSng α invar isSng +
map_ball α invar ball +
map_bex α invar bex +
map_size α invar size +
map_size_abort α invar size_abort +
map_sel' α invar sel +
map_to_list α invar to_list +
list_to_map α invar to_map
for ops :: "('k,'v,'s,'more) map_ops_scheme"
begin
lemmas correct =
empty_correct
sng_correct
lookup_correct
update_correct
update_dj_correct
delete_correct
restrict_correct
add_correct
add_dj_correct
isEmpty_correct
isSng_correct
ball_correct
bex_correct
size_correct
size_abort_correct
to_list_correct
to_map_correct
end
lemmas StdMap_intro = StdMap.intro[rem_dup_prems]
locale StdMap_no_invar = StdMap + map_no_invar α invar
record ('k,'v,'s) omap_ops = "('k,'v,'s) map_ops" +
map_op_ordered_list_it :: "'s ⇒ ('k,'v,('k×'v) list) map_iterator"
map_op_rev_list_it :: "'s ⇒ ('k,'v,('k×'v) list) map_iterator"
map_op_min :: "'s ⇒ ('k × 'v ⇒ bool) ⇒ ('k × 'v) option"
map_op_max :: "'s ⇒ ('k × 'v ⇒ bool) ⇒ ('k × 'v) option"
map_op_to_sorted_list :: "'s ⇒ ('k × 'v) list"
map_op_to_rev_list :: "'s ⇒ ('k × 'v) list"
locale StdOMapDefs = StdMapDefs ops
+ poly_map_iterateoi_defs "map_op_ordered_list_it ops"
+ poly_map_rev_iterateoi_defs "map_op_rev_list_it ops"
for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
begin
abbreviation ordered_list_it where "ordered_list_it
≡ map_op_ordered_list_it ops"
abbreviation rev_list_it where "rev_list_it
≡ map_op_rev_list_it ops"
abbreviation min where "min == map_op_min ops"
abbreviation max where "max == map_op_max ops"
abbreviation to_sorted_list where
"to_sorted_list ≡ map_op_to_sorted_list ops"
abbreviation to_rev_list where "to_rev_list ≡ map_op_to_rev_list ops"
end
locale StdOMap =
StdOMapDefs ops +
StdMap ops +
poly_map_iterateoi α invar ordered_list_it +
poly_map_rev_iterateoi α invar rev_list_it +
map_min α invar min +
map_max α invar max +
map_to_sorted_list α invar to_sorted_list +
map_to_rev_list α invar to_rev_list
for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
begin
end
lemmas StdOMap_intro =
StdOMap.intro[OF StdMap_intro, rem_dup_prems]
end
Theory Robdd
section ‹\isaheader{ROBDDs}›
theory Robdd
imports Main "../ICF/spec/MapSpec" "../Iterator/SetIteratorOperations"
begin
text ‹Let's first fix some datatypes for BDDs or more specifically
for reduced ordered binary decision diagrams (OBDDs).›
type_synonym node_id = nat
type_synonym var = nat
type_synonym assigment = "var ⇒ bool"
datatype robdd = robdd_leaf bool | robdd_var node_id robdd var robdd
abbreviation "robdd_zero ≡ robdd_leaf False"
abbreviation "robdd_one ≡ robdd_leaf True"
primrec robdd_α where
"robdd_α (robdd_leaf f) a = f"
| "robdd_α (robdd_var i l v r) a = (if a v then robdd_α l a else robdd_α r a)"
lemma robdd_α_simps_leafs [simp] :
"robdd_α (robdd_leaf f1) = robdd_α (robdd_leaf f2) ⟷ (f1 = f2)"
by (simp add: fun_eq_iff)
primrec robdd_get_id :: "robdd ⇒ node_id" where
"robdd_get_id (robdd_leaf f) = (if f then 1 else 0)"
| "robdd_get_id (robdd_var i l v r) = i"
primrec robdd_get_var :: "robdd ⇒ var" where
"robdd_get_var (robdd_leaf f) = 0"
| "robdd_get_var (robdd_var i l v r) = v"
primrec robdd_get_left :: "robdd ⇒ robdd" where
"robdd_get_left (robdd_leaf f) = robdd_leaf f"
| "robdd_get_left (robdd_var i l v r) = l"
primrec robdd_get_right :: "robdd ⇒ robdd" where
"robdd_get_right (robdd_leaf f) = robdd_leaf f"
| "robdd_get_right (robdd_var i l v r) = r"
primrec robdd_to_bool :: "robdd ⇒ bool option" where
"robdd_to_bool (robdd_leaf f) = Some f"
| "robdd_to_bool (robdd_var i l v r) = None"
primrec robdd_is_leaf where
"robdd_is_leaf (robdd_leaf _) = True"
| "robdd_is_leaf (robdd_var _ _ _ _) = False"
lemma robdd_is_leaf_alt_def :
"robdd_is_leaf b ⟷ (b = robdd_one ∨ b = robdd_zero)"
by (cases b) auto
text ‹IDs are just used a convinience for performance reasons. Therefore,
we define two robdds to be equivalent if they are equal up to ids.›
primrec robdd_equiv where
"robdd_equiv (robdd_leaf f) b = (b = robdd_leaf f)"
| "robdd_equiv (robdd_var i l v r) b =
(∃i' l' r'. b = robdd_var i' l' v r' ∧ robdd_equiv l l' ∧ robdd_equiv r r')"
lemma robdd_equiv_simps[simp] :
"robdd_equiv b (robdd_leaf f) = (b = robdd_leaf f)"
"robdd_equiv b b"
by (induct b, auto)
subsection ‹subrobdds›
text ‹It is for later definitions important to be able to talk about all the
robdds that form a robdd. This leads to the definition of subrobdds.›
primrec subrobdds :: "robdd ⇒ robdd set" where
"subrobdds (robdd_leaf f) = {robdd_leaf f}"
| "subrobdds (robdd_var i l v r) =
(insert (robdd_var i l v r) (subrobdds l ∪ subrobdds r))"
definition subrobdds_proper :: "robdd ⇒ robdd set" where
"subrobdds_proper b = (subrobdds b) - {b}"
lemma subrobdds_alt_def :
"subrobdds b = insert b (subrobdds_proper b)"
by (cases b) (simp_all add: subrobdds_proper_def)
lemma subobbds_proper_size:
"b1 ∈ subrobdds_proper b2 ⟹ size_robdd b1 < size_robdd b2"
proof (induct b2 arbitrary: b1)
case (robdd_leaf f) thus ?case by (simp add: subrobdds_proper_def)
next
case (robdd_var i l v r)
note indhyp_l = robdd_var(1)
note indhyp_r = robdd_var(2)
from robdd_var(3) have b1_in_cases: "b1 ∈ subrobdds l ∨ b1 ∈ subrobdds r" by (simp add: subrobdds_proper_def)
show ?case
proof (cases "b1 ∈ subrobdds l")
case True with indhyp_l[of b1] show ?thesis
apply (cases "b1 = l")
apply (simp_all add: subrobdds_proper_def)
done
next
case False
with b1_in_cases have "b1 ∈ subrobdds r" by blast
with indhyp_r[of b1] show ?thesis
apply (cases "b1 = r")
apply (simp_all add: subrobdds_proper_def)
done
qed
qed
lemma subrobdds_size:
"b1 ∈ subrobdds b2 ⟹ size_robdd b1 ≤ size_robdd b2"
unfolding subrobdds_alt_def by simp (metis le_eq_less_or_eq subobbds_proper_size)
lemma subrobdds_refl[simp]: "b ∈ subrobdds b" by (simp add: subrobdds_alt_def)
lemma subrobdds_antisym:
"b1 ∈ subrobdds b2 ⟹ b2 ∈ subrobdds b1 ⟹ b1 = b2"
apply (cases "b1 = b2")
apply (simp_all add: subrobdds_alt_def)
apply (metis order_less_asym' subobbds_proper_size)
done
lemma subrobdds_trans :
"b1 ∈ subrobdds b2 ⟹ b2 ∈ subrobdds b3 ⟹ b1 ∈ subrobdds b3"
apply (induct b3 arbitrary: b1 b2)
apply (simp_all)
apply (elim disjE)
apply (simp_all)
done
lemma subrobdds_proper_simps [simp] :
"subrobdds_proper (robdd_leaf f) = {}"
"subrobdds_proper (robdd_var i l v r) =
(insert l (insert r (subrobdds_proper l ∪ subrobdds_proper r)))"
proof -
show "subrobdds_proper (robdd_leaf f) = {}"
by (simp_all add: subrobdds_proper_def)
next
have "subrobdds_proper (robdd_var i l v r) = subrobdds l ∪ subrobdds r - {robdd_var i l v r}"
by (simp add: subrobdds_proper_def)
also have "... = subrobdds l ∪ subrobdds r"
proof -
from subrobdds_size [of "robdd_var i l v r" l] subrobdds_size [of "robdd_var i l v r" r]
have "robdd_var i l v r ∉ subrobdds l" "robdd_var i l v r ∉ subrobdds r" by auto
thus ?thesis by auto
qed
also have "... = (insert l (insert r (subrobdds_proper l ∪ subrobdds_proper r)))"
by (auto simp add: subrobdds_proper_def)
finally show "subrobdds_proper (robdd_var i l v r) =
(insert l (insert r (subrobdds_proper l ∪ subrobdds_proper r)))" .
qed
lemma subrobdds_subset_simp :
"subrobdds b1 ⊆ subrobdds b2 ⟷ b1 ∈ subrobdds b2"
by (metis subrobdds_refl subrobdds_trans subset_iff)
definition subrobdds_set where
"subrobdds_set bs = ⋃(subrobdds ` bs)"
lemma subrobdds_set_simps [simp] :
"subrobdds_set {} = {}"
"subrobdds_set (insert b bs) = subrobdds b ∪ subrobdds_set bs"
"subrobdds_set (bs1 ∪ bs2) = subrobdds_set bs1 ∪ subrobdds_set bs2"
unfolding subrobdds_set_def by simp_all
lemma subrobdds_set_subset_simp :
"subrobdds b ⊆ subrobdds_set bs ⟷ b ∈ subrobdds_set bs"
unfolding subrobdds_set_def
by (auto simp add: subset_iff dest: subrobdds_trans)
lemma subrobdds_set_idempot [simp] :
"subrobdds_set (subrobdds_set bs) = subrobdds_set bs"
unfolding subrobdds_set_def
by (auto dest: subrobdds_trans intro: subrobdds_refl)
lemma subrobdds_set_idempot2 [simp] :
"subrobdds_set (subrobdds b) = subrobdds b"
using subrobdds_set_idempot[of "{b}"]
by simp
lemma subrobdds_set_mono :
"bs ⊆ subrobdds_set bs"
unfolding subrobdds_set_def by auto
lemma subrobdds_set_mono2 :
"bs1 ⊆ bs2 ⟹ (subrobdds_set bs1 ⊆ subrobdds_set bs2)"
unfolding subrobdds_set_def by auto
subsection ‹Invariants›
subsubsection ‹IDs›
text ‹Ids are just added for convienience and performance. Two ROBDDs should have
the same id if and only if they have the same semantics. This way, the equivalence check
of ROBDDs can be reduced to an equality check of ids.›
definition robdd_invar_ids where
"robdd_invar_ids bs =
(∀b1 b2. (b1 ∈ subrobdds_set bs ∧ b2 ∈ subrobdds_set bs) ⟶
((robdd_α b1 = robdd_α b2) ⟷ robdd_get_id b1 = robdd_get_id b2))"
text ‹leafs can often be implicitly added›
definition robdd_invar_ids_leafs where
"robdd_invar_ids_leafs bs =
(∀b f. (b ∈ subrobdds_set bs) ⟶
((robdd_α b = robdd_α (robdd_leaf f)) ⟷ robdd_get_id b = robdd_get_id (robdd_leaf f)))"
definition robdd_invar_ids_full where
"robdd_invar_ids_full bs ≡
robdd_invar_ids bs ∧ robdd_invar_ids_leafs bs"
lemma robdd_invar_ids_full_alt_def :
"robdd_invar_ids_full bs =
robdd_invar_ids (insert robdd_zero (insert robdd_one bs))"
unfolding robdd_invar_ids_full_def robdd_invar_ids_def robdd_invar_ids_leafs_def
apply (simp)
apply (intro iffI allI impI, elim conjE impE disjE)
apply (simp_all)
apply (metis+) [3]
apply (elim conjE impE disjE)
apply (simp_all)
apply (metis+)
done
text ‹Together with other invariants it can the later be derived that
two robdds have the same id if and only if they are equal.›
definition robdd_invar_ids_equal where
"robdd_invar_ids_equal bs =
(∀b1 b2. (b1 ∈ subrobdds_set bs ∧ b2 ∈ subrobdds_set bs) ⟶
((robdd_get_id b1 = robdd_get_id b2) ⟷ b1 = b2))"
definition robdd_invar_ids_leafs_equal where
"robdd_invar_ids_leafs_equal bs =
(∀b f. (b ∈ subrobdds_set bs) ⟶
((robdd_get_id b = robdd_get_id (robdd_leaf f)) ⟷ b = (robdd_leaf f)))"
definition robdd_invar_ids_full_equal where
"robdd_invar_ids_full_equal bs ≡
robdd_invar_ids_equal bs ∧ robdd_invar_ids_leafs_equal bs"
lemma robdd_invar_ids_full_equal_alt_def :
"robdd_invar_ids_full_equal bs =
robdd_invar_ids_equal (insert robdd_zero (insert robdd_one bs))"
unfolding robdd_invar_ids_full_equal_def robdd_invar_ids_equal_def robdd_invar_ids_leafs_equal_def
apply (simp)
apply (intro iffI allI impI)
apply (elim conjE impE disjE)
apply (simp_all)
apply (metis+) [3]
apply (metis One_nat_def robdd_get_id.simps(1))
done
lemma robdd_invar_idsI:
assumes "⋀b1 b2. ⟦b1 ∈ (subrobdds_set bs); b2 ∈ (subrobdds_set bs)⟧ ⟹
(robdd_α b1 = robdd_α b2) ⟷ (robdd_get_id b1 = robdd_get_id b2)"
shows "robdd_invar_ids bs"
using assms unfolding robdd_invar_ids_def by blast
lemma robdd_invar_idsD:
assumes "robdd_invar_ids bs"
assumes "b1 ∈ (subrobdds_set bs)"
"b2 ∈ (subrobdds_set bs)"
shows "robdd_α b1 = robdd_α b2 ⟷ robdd_get_id b1 = robdd_get_id b2"
using assms unfolding robdd_invar_ids_def by blast
lemma robdd_invar_ids_subset_rule :
"robdd_invar_ids bs1 ⟹ bs2 ⊆ bs1 ⟹ robdd_invar_ids bs2"
by (simp add: robdd_invar_ids_def subset_iff subrobdds_set_def) metis
lemma robdd_invar_ids_expand :
shows "robdd_invar_ids (subrobdds_set bs) = robdd_invar_ids bs"
by (simp add: robdd_invar_ids_def subrobdds_set_idempot)
lemma robdd_invar_ids_subset_subrobdds_rule :
assumes pre: "⋀b2. b2 ∈ bs2 ⟹ ∃b1 ∈ bs1. b2 ∈ (subrobdds b1)"
and invar_bs1: "robdd_invar_ids bs1"
shows "robdd_invar_ids bs2"
apply (rule robdd_invar_ids_subset_rule [of "subrobdds_set bs1"])
apply (simp add: robdd_invar_ids_expand invar_bs1)
apply (simp add: subset_iff pre subrobdds_set_def)
done
text ‹If two ROBDDs are equal up to ids and then they are in fact equal.›
lemma robdd_invar_ids_equiv_implies_eq:
assumes "robdd_invar_ids bs"
and "b1 ∈ bs" "b2 ∈ bs"
and "robdd_equiv b1 b2"
shows "b1 = b2"
using assms
proof (induct b1 arbitrary: b2 bs)
case (robdd_var i l v r)
note indhyp_l = robdd_var(1)
note indhyp_r = robdd_var(2)
note invar_ids = robdd_var(3)
note in_bs = robdd_var(4,5)
note equiv_b2 = robdd_var(6)
from equiv_b2 obtain i' l' r' where
b2_eq: "b2 = robdd_var i' l' v r'" and
equiv_l: "robdd_equiv l l'" and
equiv_r: "robdd_equiv r r'"
unfolding robdd_equiv.simps by blast
have invar_ids': "robdd_invar_ids {robdd_var i l v r, b2}"
apply (rule robdd_invar_ids_subset_subrobdds_rule[OF _ invar_ids])
apply (auto simp add: subrobdds_alt_def in_bs)
done
have invar_ids_sub: "robdd_invar_ids {l, r, l', r'}"
apply (rule robdd_invar_ids_subset_subrobdds_rule[OF _ invar_ids'])
apply (auto simp add: b2_eq subrobdds_alt_def)
done
from indhyp_l [OF invar_ids_sub _ _ equiv_l]
indhyp_r [OF invar_ids_sub _ _ equiv_r]
have l'_eq[simp]: "l' = l" and r'_eq[simp]: "r' = r" by simp_all
from robdd_invar_idsD[OF invar_ids', of "robdd_var i l v r" b2]
have i'_eq[simp]: "i' = i" by (simp add: b2_eq robdd_α_def subrobdds_set_def)
show ?case by (simp add: b2_eq)
qed simp_all
subsubsection ‹Variable order›
text ‹We are formalising reduced \emph{ordered} binary decision diagrams. Therefore, the
variables need to appear in order.›
primrec robdd_invar_vars_greater where
"robdd_invar_vars_greater n (robdd_leaf f) = True"
| "robdd_invar_vars_greater n (robdd_var i l v r) =
(n ≤ v ∧ (robdd_invar_vars_greater (Suc v) l) ∧ (robdd_invar_vars_greater (Suc v) r))"
definition robdd_invar_vars where
"robdd_invar_vars b = robdd_invar_vars_greater 0 b"
lemma robdd_invar_vars_greater___weaken :
"robdd_invar_vars_greater n b ⟹ n' ≤ n ⟹ robdd_invar_vars_greater n' b"
by (cases b) (simp_all)
lemma robdd_invar_vars_impl:
"robdd_invar_vars_greater n robdd ⟹ robdd_invar_vars robdd"
unfolding robdd_invar_vars_def
by (rule robdd_invar_vars_greater___weaken[of n]) (simp_all)
subsubsection ‹Reduced›
text ‹We are formalising \emph{reduced} ordered binary decision diagrams. Therefore, it should
be reduced.›
primrec robdd_invar_reduced where
"robdd_invar_reduced (robdd_leaf f) = True"
| "robdd_invar_reduced (robdd_var i l v r) =
(¬(robdd_equiv l r) ∧ (robdd_invar_reduced l) ∧ (robdd_invar_reduced r))"
lemma robdd_invar_reduced_leaf [simp]:
"robdd_invar_reduced (robdd_leaf v) = True"
by (cases v) (simp_all)
lemma subrobdds_leaf_in_reduced:
"robdd_invar_reduced b ⟹ ¬(robdd_is_leaf b) ⟹ (robdd_one ∈ subrobdds b ∧ robdd_zero ∈ subrobdds b)"
proof (induct b)
case (robdd_leaf f)
thus ?case by simp
next
case (robdd_var i l v r)
note reduced_b = robdd_var(3)
from reduced_b have not_equiv_lr: "¬ robdd_equiv l r" and
reduced_l: "robdd_invar_reduced l" and reduced_r: "robdd_invar_reduced r"
by simp_all
note indhyp_l = robdd_var(1)[OF reduced_l]
note indhyp_r = robdd_var(2)[OF reduced_r]
show ?case
proof (cases "robdd_is_leaf l")
case False
with indhyp_l show ?thesis by simp
next
case True note l_is_leaf = this
show ?thesis
proof (cases "robdd_is_leaf r")
case False
with indhyp_r show ?thesis by simp
next
case True note r_is_leaf = this
from l_is_leaf r_is_leaf not_equiv_lr show ?thesis
unfolding robdd_is_leaf_alt_def by auto
qed
qed
qed
lemma subrobdds_set_leaf_in_reduced:
assumes bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar_reduced b"
and bs_neq_leaf_set: "bs ≠ {robdd_one}" "bs ≠ {robdd_zero}"
and bs_neq_emp: "bs ≠ {}"
shows "robdd_one ∈ subrobdds_set bs ∧ robdd_zero ∈ subrobdds_set bs"
proof (cases "∃b∈bs. ¬(robdd_is_leaf b)")
case True
then obtain b where b_in: "b ∈ bs" and not_leaf_b: "¬(robdd_is_leaf b)" by blast
from bs_OK b_in have invar_reduced: "robdd_invar_reduced b" by simp
from subrobdds_leaf_in_reduced[OF invar_reduced not_leaf_b]
have in_b: "robdd_one ∈ subrobdds b ∧ robdd_zero ∈ subrobdds b" .
from in_b b_in show ?thesis
unfolding subrobdds_set_def by auto
next
case False hence only_leafs: "⋀b. b ∈ bs ⟹ robdd_is_leaf b" by simp
from bs_neq_emp obtain b1 where b1_in: "b1 ∈ bs" by auto
with only_leafs have leaf_b1: "robdd_is_leaf b1" by simp
from leaf_b1 bs_neq_leaf_set have "bs ≠ {b1}"
by (auto simp add: robdd_is_leaf_alt_def)
with b1_in obtain b2 where b2_in: "b2 ∈ bs" and b2_neq: "b1 ≠ b2"
by auto
from b2_in only_leafs have leaf_b2: "robdd_is_leaf b2" by simp
from b1_in b2_in b2_neq leaf_b1 leaf_b2
have "robdd_one ∈ bs ∧ robdd_zero ∈ bs"
unfolding robdd_is_leaf_alt_def by auto
thus ?thesis unfolding subrobdds_set_def
by simp (metis subrobdds_refl)
qed
lemma robdd_invar_ids_leafs_intro :
assumes bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar_reduced b"
and weak_invar: "robdd_invar_ids bs"
shows "robdd_invar_ids_leafs bs"
proof (cases "bs = {} ∨ bs = {robdd_one} ∨ bs = {robdd_zero}")
case True thus ?thesis
proof (elim disjE)
assume "bs = {}" thus "robdd_invar_ids_leafs bs"
unfolding robdd_invar_ids_leafs_def by simp
next
assume "bs = {robdd_one}" thus "robdd_invar_ids_leafs bs"
unfolding robdd_invar_ids_leafs_def
by simp
next
assume "bs = {robdd_zero}" thus "robdd_invar_ids_leafs bs"
unfolding robdd_invar_ids_leafs_def
by simp
qed
next
case False
with subrobdds_set_leaf_in_reduced[of bs, OF bs_OK]
have one_in: "robdd_one ∈ subrobdds_set bs" and
zero_in: "robdd_zero ∈ subrobdds_set bs" by auto
with weak_invar show ?thesis
unfolding robdd_invar_ids_leafs_def robdd_invar_ids_def
by auto
qed
subsubsection ‹Overall Invariant›
definition robdd_invar_ext where
"robdd_invar_ext bs n b = (b ∈ subrobdds_set bs ∧ robdd_invar_ids bs ∧ robdd_invar_vars_greater n b ∧ robdd_invar_reduced b)"
definition robdd_invar where
"robdd_invar b = robdd_invar_ext {b} 0 b"
lemma robdd_invar_alt_def :
"robdd_invar b = (robdd_invar_ids {b} ∧ robdd_invar_vars b ∧ robdd_invar_reduced b)"
unfolding robdd_invar_def robdd_invar_ext_def robdd_invar_vars_def subrobdds_set_def
by simp
lemma robdd_invar_simps_leafs [simp]: "robdd_invar (robdd_leaf value)"
by (simp add: robdd_invar_alt_def robdd_invar_vars_def robdd_invar_ids_def subrobdds_set_def)
lemma robdd_invar_simps_var :
"robdd_invar (robdd_var i l v r) ⟹ (¬(robdd_equiv l r) ∧ robdd_invar l ∧ robdd_invar r)"
apply (simp add: robdd_invar_alt_def robdd_invar_ids_def robdd_invar_vars_def subrobdds_set_def)
apply (metis robdd_invar_vars_def robdd_invar_vars_impl)
done
lemma robdd_invar_subrobdds_set :
assumes bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar b"
and b_in: "b ∈ subrobdds_set bs"
shows "robdd_invar b"
proof -
from b_in obtain b' where b'_in: "b' ∈ bs" and b_in': "b ∈ subrobdds b'"
unfolding subrobdds_set_def by auto
from bs_OK[OF b'_in] have "robdd_invar b'" .
with b_in' show "robdd_invar b"
apply (induct b')
apply simp_all
apply (metis robdd_invar_simps_var)
done
qed
lemma robdd_invar_ext_simps [simp] :
"robdd_invar_ext bs n (robdd_leaf f) = (robdd_invar_ids bs ∧ ((robdd_leaf f) ∈ (subrobdds_set bs)))" (is ?T1)
"robdd_invar_ext bs n (robdd_var i l v r) =
((robdd_var i l v r) ∈ (subrobdds_set bs) ∧ ¬(robdd_equiv l r) ∧ n ≤ v ∧ robdd_invar_ext bs (Suc v) l ∧ robdd_invar_ext bs (Suc v) r)" (is ?T2)
proof -
show ?T1 by (auto simp add: robdd_invar_ext_def)
next
show ?T2 (is "?ls = ?rs")
proof
assume ?rs thus ?ls by (simp add: robdd_invar_ext_def subrobdds_set_def)
next
assume ?ls
then obtain b where b_props: "b ∈ bs" "robdd_var i l v r ∈ subrobdds b"
by (auto simp add: robdd_invar_ext_def subrobdds_set_def)
from subrobdds_trans [of l "robdd_var i l v r" b]
subrobdds_trans [of r "robdd_var i l v r" b]
have "r ∈ subrobdds b" "l ∈ subrobdds b" by (simp_all add: b_props)
with ‹?ls› ‹b ∈ bs› show ?rs by (auto simp add: robdd_invar_ext_def subrobdds_set_def)
qed
qed
lemma rodd_invar_ext_idempot_subrobdds_set [simp]:
"robdd_invar_ext (subrobdds_set bs) n b = robdd_invar_ext bs n b"
unfolding robdd_invar_ext_def robdd_invar_ids_def
by simp
lemma robdd_invar_ext_weaken :
assumes pre: "robdd_invar_ext bs2 n b"
and bs2_props: "⋀b2. b ∈ subrobdds_set bs2 ⟹ b2 ∈ bs1 ⟹ ∃b1 ∈ bs2. b2 ∈ (subrobdds b1)"
and b_in: "b ∈ subrobdds_set bs2 ⟹ b ∈ subrobdds_set bs1"
and m_le: "m ≤ n"
shows "robdd_invar_ext bs1 m b"
proof -
from pre have
"b ∈ subrobdds_set bs2"
"robdd_invar_ids bs2"
"robdd_invar_vars_greater n b"
"robdd_invar_reduced b"
unfolding robdd_invar_ext_def by simp_all
from ‹b ∈ subrobdds_set bs2› b_in
have b_in: "b ∈ subrobdds_set bs1" by simp
have invar_ids: "robdd_invar_ids bs1"
apply (rule robdd_invar_ids_subset_subrobdds_rule [OF bs2_props])
apply (simp add: ‹b ∈ subrobdds_set bs2›)
apply simp
apply fact
done
have invar_greater: "robdd_invar_vars_greater m b"
by (rule robdd_invar_vars_greater___weaken[OF ‹robdd_invar_vars_greater n b› m_le])
show ?thesis
unfolding robdd_invar_ext_def
by (simp add: b_in invar_ids ‹robdd_invar_reduced b› invar_greater)
qed
lemma robdd_invar_ext_weaken_var :
assumes pre: "robdd_invar_ext bs n b"
and m_le: "m ≤ n"
shows "robdd_invar_ext bs m b"
apply (rule robdd_invar_ext_weaken[OF pre _ _ m_le])
apply (simp_all add: Bex_def)
apply (metis subrobdds_refl)
done
lemma robdd_invar_impl :
assumes invar_ext: "robdd_invar_ext bs n b"
shows "robdd_invar b"
unfolding robdd_invar_def
apply (rule robdd_invar_ext_weaken[OF invar_ext])
apply (simp_all add: subrobdds_set_def)
done
lemma robdd_α_invar_greater :
assumes invar_vars: "robdd_invar_vars_greater n b"
and a_equiv: "⋀v. v ≥ n ⟹ a1 v = a2 v"
shows "robdd_α b a1 = robdd_α b a2"
using assms
apply (induct b)
apply (simp_all)
apply (metis le_Suc_eq robdd_invar_vars_greater___weaken)
done
subsection ‹ROBDDs are unique›
text ‹An important property of ROBDDs is that two ROBDDs have the same semantics if and only
if they are equal (up to ids in our case). Before we can prove this property some
lemmata are needed.›
lemma robdd_unique_leaf :
assumes invars_b: "robdd_invar_vars b" "robdd_invar_reduced b"
and sem_eq: "robdd_α b = robdd_α (robdd_leaf value)"
shows "b = (robdd_leaf value)"
using assms
proof (induct b)
case (robdd_leaf f) thus ?case by (simp add: fun_eq_iff)
next
case (robdd_var i l v r)
note invar_l = robdd_var(1)
note invar_r = robdd_var(2)
note invars = robdd_var(3,4)
note α_eq = robdd_var(5)
{ fix a
from invars(1) have invars_b11_b12: "robdd_invar_vars_greater (Suc v) l"
"robdd_invar_vars_greater (Suc v) r"
by (simp_all add: robdd_invar_vars_def)
let ?a1 = "λv'. if v = v' then True else a v'"
let ?a2 = "λv'. if v = v' then False else a v'"
from α_eq have a_neg: "⋀a. (if a v then robdd_α l a else robdd_α r a) ⟷ value"
by (simp add: fun_eq_iff)
from robdd_α_invar_greater [OF invars_b11_b12(1), of a ?a1, symmetric]
robdd_α_invar_greater [OF invars_b11_b12(2), of a ?a2, symmetric]
a_neg[of ?a1] a_neg[of ?a2]
have "robdd_α l a = value ∧ robdd_α r a = value" by simp
}
hence α_l: "robdd_α l = robdd_α (robdd_leaf value)" and
α_r: "robdd_α r = robdd_α (robdd_leaf value)"
by (simp_all add: fun_eq_iff)
from invars have "robdd_invar_vars l" "robdd_invar_vars r"
"robdd_invar_reduced l" "robdd_invar_reduced r"
apply (simp_all add: robdd_invar_vars_def)
apply (metis robdd_invar_vars_def robdd_invar_vars_impl)+
done
with invar_l[OF _ _ α_l] invar_r[OF _ _ α_r]
have "l = r" by simp
with invars(2) have "False" by simp
thus ?case by simp
qed
lemma robdd_unique_var :
assumes invars_b1: "robdd_invar_vars (robdd_var i1 l1 v1 r1)" "robdd_invar_reduced (robdd_var i1 l1 v1 r1)"
and invars_b2: "robdd_invar_vars (robdd_var i2 l2 v2 r2)" "robdd_invar_reduced (robdd_var i2 l2 v2 r2)"
and sem_neq_b1: "robdd_α l1 ≠ robdd_α r1"
and sem_neq_b2: "robdd_α l2 ≠ robdd_α r2"
and sem_eq: "robdd_α (robdd_var i1 l1 v1 r1) = robdd_α (robdd_var i2 l2 v2 r2)"
shows "v1 = v2 ∧ robdd_α l1 = robdd_α l2 ∧ robdd_α r1 = robdd_α r2"
proof -
{ fix i1 l1 v1 r1 i2 l2 v2 r2 n1 n2
assume invars_b1: "robdd_invar_vars_greater n1 (robdd_var i1 l1 v1 r1)" "robdd_invar_reduced (robdd_var i1 l1 v1 r1)"
and invars_b2: "robdd_invar_vars_greater n2 (robdd_var i2 l2 v2 r2)" "robdd_invar_reduced (robdd_var i2 l2 v2 r2)"
and sem_neq: "robdd_α l1 ≠ robdd_α r1"
and sem_eq: "robdd_α (robdd_var i1 l1 v1 r1) = robdd_α (robdd_var i2 l2 v2 r2)"
and ord: "v1 ≤ v2"
from invars_b1(1) have invars_lr1: "robdd_invar_vars_greater (Suc v1) l1"
"robdd_invar_vars_greater (Suc v1) r1" by simp_all
from invars_b2(1) have invars_lr2: "robdd_invar_vars_greater (Suc v1) l2"
"robdd_invar_vars_greater (Suc v1) r2"
"v1 ≠ v2 ⟹ robdd_invar_vars_greater v1 (robdd_var i1 l1 v1 r1)"
apply (simp_all add: robdd_invar_ext_def robdd_invar_vars_def)
apply (metis not_less_eq_eq robdd_invar_vars_greater___weaken ord)
apply (metis not_less_eq_eq robdd_invar_vars_greater___weaken ord)
apply (simp add: invars_lr1)
done
from sem_eq have sem_eq_a: "⋀a. robdd_α (robdd_var i1 l1 v1 r1) a = robdd_α (robdd_var i2 l2 v2 r2) a"
by (simp add: fun_eq_iff)
define a1 where "a1 a v' = (if v1 = v' then True else a v')" for a v'
define a2 where "a2 a v' = (if v1 = v' then False else a v')" for a v'
have a12_eval: "⋀a. a1 a v1" "⋀a. ~(a2 a v1)" "⋀a v. v ≠ v1 ⟹ a1 a v = a v ∧ a2 a v = a v"
unfolding a1_def a2_def by simp_all
{ fix a
from robdd_α_invar_greater [OF invars_lr1(1), of a "a1 a", symmetric]
robdd_α_invar_greater [OF invars_lr1(2), of a "a2 a", symmetric]
robdd_α_invar_greater [OF invars_lr2(1), of a "a1 a", symmetric]
robdd_α_invar_greater [OF invars_lr2(2), of a "a2 a", symmetric]
robdd_α_invar_greater [OF invars_lr1(1), of a "a2 a", symmetric]
robdd_α_invar_greater [OF invars_lr1(2), of a "a1 a", symmetric]
robdd_α_invar_greater [OF invars_lr2(1), of a "a2 a", symmetric]
robdd_α_invar_greater [OF invars_lr2(2), of a "a1 a", symmetric]
sem_eq_a[of "a1 a"] sem_eq_a[of "a2 a"]
have a12_sem : "robdd_α l1 (a1 a) = robdd_α l1 a" "robdd_α l2 (a1 a) = robdd_α l2 a"
"robdd_α r1 (a2 a) = robdd_α r1 a" "robdd_α r2 (a2 a) = robdd_α r2 a"
"robdd_α l1 (a2 a) = robdd_α l1 a" "robdd_α l2 (a2 a) = robdd_α l2 a"
"robdd_α r1 (a1 a) = robdd_α r1 a" "robdd_α r2 (a2 a) = robdd_α r2 a"
"v1 ≠ v2 ⟹ robdd_α r1 a = robdd_α (robdd_var i2 l2 v2 r2) a"
"v1 ≠ v2 ⟹ robdd_α l1 a = robdd_α (robdd_var i2 l2 v2 r2) a"
unfolding a1_def a2_def by simp_all
} note a12_sem = this
from a12_sem(9,10) have "v1 ≠ v2 ⟹ robdd_α l1 = robdd_α r1"
by (simp add: fun_eq_iff)
with sem_neq have v2_eq: "v2 = v1" by metis
{ fix a
from sem_eq_a[of "a1 a"] sem_eq_a[of "a2 a"] a12_sem[of a]
have "robdd_α l1 a = robdd_α l2 a ∧ robdd_α r1 a = robdd_α r2 a"
by (simp add: v2_eq a12_eval)
}
hence "v1 = v2 ∧ robdd_α l1 = robdd_α l2 ∧ robdd_α r1 = robdd_α r2"
by (simp add: fun_eq_iff v2_eq)
} note aux = this
show ?thesis
proof (cases "v1 ≤ v2")
case True note v1_le = this
from aux[OF invars_b1[unfolded robdd_invar_vars_def] invars_b2[unfolded robdd_invar_vars_def] sem_neq_b1 sem_eq v1_le]
show ?thesis by simp
next
case False
hence v2_le: "v2 ≤ v1" by simp
from aux[OF invars_b2[unfolded robdd_invar_vars_def] invars_b1[unfolded robdd_invar_vars_def] sem_neq_b2 sem_eq[symmetric] v2_le]
show ?thesis by simp
qed
qed
lemma robdd_equiv_implies_sem_equiv :
"robdd_equiv b1 b2 ⟹ robdd_α b1 = robdd_α b2"
proof (induct b1 arbitrary: b2)
case (robdd_var i l v r)
note ind_hyp_l = robdd_var(1)
note ind_hyp_r = robdd_var(2)
note equiv_b2 = robdd_var(3)
from equiv_b2 obtain i' l' r' where
b2_eq: "b2 = robdd_var i' l' v r'" and
equiv_l: "robdd_equiv l l'" and
equiv_r: "robdd_equiv r r'"
unfolding robdd_equiv.simps by blast
from ind_hyp_l[OF equiv_l] ind_hyp_r[OF equiv_r] b2_eq
show ?case by simp
qed simp_all
lemma sem_equiv_implies_robdd_equiv :
assumes "robdd_invar_vars b1" "robdd_invar_reduced b1"
and "robdd_invar_vars b2" "robdd_invar_reduced b2"
and "robdd_α b1 = robdd_α b2"
shows "robdd_equiv b1 b2"
using assms
proof (induct "(b1, b2)" arbitrary: b1 b2 rule: measure_induct_rule [of "λ(b1,b2). size_robdd b1 + size_robdd b2"])
case less
note ind_hyp = less(1)
note invars_b1 = less(2,3)
note invars_b2 = less(4,5)
note sem_eq = less(6)
show ?case
proof (cases b1)
case (robdd_leaf f) thus ?thesis using robdd_unique_leaf[OF invars_b2] sem_eq by simp
next
case (robdd_var i1 l1 v1 r1) note b1_eq = this
show ?thesis
proof (cases b2)
case (robdd_leaf f) thus ?thesis using robdd_unique_leaf[OF invars_b1] sem_eq
by (simp add: fun_eq_iff)
next
case (robdd_var i2 l2 v2 r2) note b2_eq = this
from invars_b1 invars_b2
have invars_sub: "robdd_invar_vars l1" "robdd_invar_vars r1"
"robdd_invar_vars l2" "robdd_invar_vars r2"
"robdd_invar_reduced l1" "robdd_invar_reduced r1"
"robdd_invar_reduced l2" "robdd_invar_reduced r2"
"¬(robdd_equiv l1 r1)" "¬(robdd_equiv l2 r2)"
unfolding b1_eq b2_eq by (simp_all add: robdd_invar_vars_def) (metis robdd_invar_vars_def robdd_invar_vars_impl)+
have aux: "v1 = v2 ∧ robdd_α l1 = robdd_α l2 ∧ robdd_α r1 = robdd_α r2"
proof (rule robdd_unique_var[OF invars_b1[unfolded b1_eq] invars_b2[unfolded b2_eq]])
show "robdd_α (robdd_var i1 l1 v1 r1) = robdd_α (robdd_var i2 l2 v2 r2)"
using invars_b1 invars_b2 sem_eq unfolding b1_eq b2_eq by simp_all
next
show "robdd_α l1 ≠ robdd_α r1"
proof (rule notI)
assume l1_α_eq: "robdd_α l1 = robdd_α r1"
with ind_hyp [of l1 r1] invars_sub
show False by (simp add: b1_eq b2_eq l1_α_eq)
qed
next
show "robdd_α l2 ≠ robdd_α r2"
proof (rule notI)
assume l2_α_eq: "robdd_α l2 = robdd_α r2"
with ind_hyp [of l2 r2] invars_sub
show False by (simp add: b1_eq b2_eq l2_α_eq)
qed
qed
with aux ind_hyp [of l1 l2]
ind_hyp [of r1 r2] invars_sub
show ?thesis by (simp_all add: b1_eq b2_eq)
qed
qed
qed
lemma robdd_equiv_alt_def_full :
assumes "robdd_invar_vars b1" "robdd_invar_reduced b1"
and "robdd_invar_vars b2" "robdd_invar_reduced b2"
shows "robdd_equiv b1 b2 ⟷ robdd_α b1 = robdd_α b2"
by (metis robdd_equiv_implies_sem_equiv sem_equiv_implies_robdd_equiv[OF assms])
lemma robdd_equiv_alt_def :
assumes "robdd_invar b1"
and "robdd_invar b2"
shows "robdd_equiv b1 b2 ⟷ robdd_α b1 = robdd_α b2"
using assms
apply (rule_tac robdd_equiv_alt_def_full)
apply (simp_all add: robdd_invar_def robdd_invar_ext_def robdd_invar_vars_def)
done
lemma robdd_unique :
assumes "robdd_invar b1"
and "robdd_invar b2"
and "robdd_invar_ids bs"
and "b1 ∈ bs" "b2 ∈ bs"
shows "robdd_α b1 = robdd_α b2 ⟷ b1 = b2"
using robdd_equiv_alt_def [OF assms(1,2)]
robdd_invar_ids_equiv_implies_eq[of bs, OF assms(3,4,5)]
by blast
lemma robdd_invar_ids_equal_intro :
assumes bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar b"
and weak_invar: "robdd_invar_ids bs"
shows "robdd_invar_ids_equal bs"
proof -
{ fix b1 b2
assume b1_in: "b1 ∈ subrobdds_set bs" and b2_in: "b2 ∈ subrobdds_set bs"
hence "robdd_invar b1 ∧ robdd_invar b2"
by (metis robdd_invar_subrobdds_set bs_OK)
with robdd_unique[of b1 b2 "subrobdds_set bs"] b1_in b2_in weak_invar
have "(robdd_α b1 = robdd_α b2) = (b1 = b2)" by (simp add: robdd_invar_ids_expand)
}
with weak_invar show ?thesis
unfolding robdd_invar_ids_equal_def robdd_invar_ids_def
by (simp)
qed
lemma robdd_invar_ids_full_equal_intro :
assumes bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar b"
and weak_invar: "robdd_invar_ids_full bs"
shows "robdd_invar_ids_full_equal bs"
unfolding robdd_invar_ids_full_equal_alt_def
apply (rule robdd_invar_ids_equal_intro)
apply (simp, elim disjE)
apply (simp)
apply (simp)
apply (simp add: bs_OK)
apply (simp add: robdd_invar_ids_full_alt_def[symmetric] weak_invar)
done
subsection ‹Variable dependency›
text ‹ROBDDs talk about assignments that consider infinitely many variables. However,
the result depends only on a finite set of variables. Let's have a closer look at these
variables.›
definition robdd_depends_on_var where
"robdd_depends_on_var v b ⟷ (∃a. robdd_α b (a(v := True)) ≠ robdd_α b (a(v := False)))"
lemma robdd_depends_on_varI :
"robdd_α b (a(v := True)) ≠ robdd_α b (a(v := False)) ⟹
robdd_depends_on_var v b"
unfolding robdd_depends_on_var_def by auto
lemma robbd_depends_on_var_leaf [simp] :
"¬(robdd_depends_on_var v (robdd_leaf f))"
by (simp_all add: robdd_depends_on_var_def fun_eq_iff)
lemma robdd_depends_on_var_invar_greater:
assumes invar: "robdd_invar_vars_greater n b"
and m_less: "m < n"
shows "¬(robdd_depends_on_var m b)"
proof -
{ fix a f
have "robdd_α b (a(m := f)) = robdd_α b a"
apply (rule robdd_α_invar_greater[OF invar, of "a(m := f)" a])
apply (insert m_less)
apply (simp)
done
}
thus ?thesis by (simp add: robdd_depends_on_var_def)
qed
lemma robbd_depends_on_var_var_impl1 :
assumes depend: "robdd_depends_on_var v (robdd_var i l v' r)"
shows "(v = v') ∨ robdd_depends_on_var v l ∨ robdd_depends_on_var v r"
proof (cases "v = v'")
case True thus ?thesis by simp
next
case False note v_neq = this
from depend obtain a where a_props:
"(if a v' then robdd_α l (a(v := True)) else robdd_α r (a(v := True))) ≠
(if a v' then robdd_α l (a(v := False)) else robdd_α r (a(v := False)))"
unfolding robdd_depends_on_var_def by (auto simp add: v_neq v_neq[symmetric])
show ?thesis
proof (cases "a v'")
case True note a_v'_eq = this
have "robdd_depends_on_var v l"
apply (rule robdd_depends_on_varI[of _ a])
apply (insert a_props a_v'_eq)
apply (simp)
done
thus ?thesis by simp
next
case False note a_v'_eq = this
have "robdd_depends_on_var v r"
apply (rule robdd_depends_on_varI[of _ a])
apply (insert a_props a_v'_eq)
apply (simp)
done
thus ?thesis by simp
qed
qed
lemma robbd_depends_on_var_var :
assumes invar: "robdd_invar (robdd_var i l v' r)"
shows "robdd_depends_on_var v (robdd_var i l v' r) ⟷
(v = v') ∨ robdd_depends_on_var v l ∨ robdd_depends_on_var v r"
proof (cases "v = v'")
case True note v_eq = this
from invar
have invar_greater: "robdd_invar_vars_greater (Suc v) l" "robdd_invar_vars_greater (Suc v) r"
unfolding robdd_invar_def robdd_invar_ext_def v_eq by simp_all
from invar robdd_equiv_alt_def[of l r]
have "robdd_α l ≠ robdd_α r" by (metis robdd_invar_simps_var)
then obtain a where not_equiv: "robdd_α l a ≠ robdd_α r a" by (simp add: fun_eq_iff) metis
from robdd_α_invar_greater[OF invar_greater(1), of "a (v := True)" a]
have l_eval: "robdd_α l (a(v := True)) = robdd_α l a" by simp
from robdd_α_invar_greater[OF invar_greater(2), of "a (v := False)" a]
have r_eval: "robdd_α r (a(v := False)) = robdd_α r a" by simp
show ?thesis
apply (simp add: v_eq[symmetric] robdd_depends_on_var_def)
apply (rule exI [where x = a])
apply (insert not_equiv)
apply (simp add: r_eval l_eval)
done
next
case False note v_neq = this
from invar have invar_greater: "robdd_invar_vars_greater (Suc v') l" "robdd_invar_vars_greater (Suc v') r"
unfolding robdd_invar_def robdd_invar_ext_def by simp_all
{ fix a f1 f2
from robdd_α_invar_greater[OF invar_greater(1), of "a (v' := f1, v := f2)" "a (v := f2)"]
robdd_α_invar_greater[OF invar_greater(2), of "a (v' := f1, v := f2)" "a (v := f2)"]
have "robdd_α l (a(v' := f1, v := f2)) = robdd_α l (a (v:=f2))"
"robdd_α r (a(v' := f1, v := f2)) = robdd_α r (a (v:=f2))" by simp_all
} note robdd_α_lr_modified = this
show ?thesis
proof (cases "robdd_depends_on_var v l")
case True note depends_on_l = this
from depends_on_l
obtain a where not_equiv: "robdd_α l (a(v := True)) ≠ robdd_α l (a(v := False))"
unfolding robdd_depends_on_var_def by metis
have "robdd_depends_on_var v (robdd_var i l v' r)"
unfolding robdd_depends_on_var_def
apply (simp add: v_neq[symmetric])
apply (rule exI [where x = "a (v':=True)"])
apply (insert not_equiv)
apply (simp add: robdd_α_lr_modified)
done
thus ?thesis by (simp add: depends_on_l)
next
case False note not_depends_on_l = this
hence l_simp: "⋀a. robdd_α l (a(v := True)) = robdd_α l (a(v := False))"
unfolding robdd_depends_on_var_def by simp
{ fix a
assume "robdd_α r (a(v := True)) ≠ robdd_α r (a(v := False))"
hence "robdd_α r (a(v' := False, v := True)) ≠ robdd_α r (a(v' := False, v := False))"
by (simp add: robdd_α_lr_modified)
}
thus ?thesis
unfolding robdd_depends_on_var_def
apply (simp add: v_neq[symmetric] v_neq l_simp)
by (metis fun_upd_same)
qed
qed
primrec robdd_used_vars where
"robdd_used_vars (robdd_leaf f) = {}"
| "robdd_used_vars (robdd_var i l v r) = robdd_used_vars l ∪ {v} ∪ robdd_used_vars r"
lemma robdd_depends_on_var_eq_used :
"robdd_invar b ⟹
robdd_depends_on_var v b ⟷ v ∈ robdd_used_vars b"
proof (induct b)
case (robdd_leaf f)
thus ?case by (simp add: robdd_depends_on_var_def)
next
case (robdd_var i l v' r)
note indhyp_l = robdd_var(1)
note indhyp_r = robdd_var(2)
note invar_b = robdd_var(3)
from invar_b have invar_l: "robdd_invar l" and invar_r: "robdd_invar r" by (metis robdd_invar_simps_var)+
from robbd_depends_on_var_var[OF invar_b, of v] indhyp_l[OF invar_l] indhyp_r[OF invar_r]
show ?case by simp
qed
lemma robdd_depends_on_var_implies_used :
"robdd_depends_on_var v b ⟹ v ∈ robdd_used_vars b"
apply (induct b)
apply (simp_all)
apply (metis robbd_depends_on_var_var_impl1)
done
subsection ‹Inverse Map›
text ‹If the invariant for ids is satisfied, one can find a find a unique mapping between ids
and ROBDDs.›
definition robdd_id_map_OK where
"robdd_id_map_OK bs m ⟷ (∀b ∈ subrobdds_set bs. m (robdd_get_id b) = Some b)"
lemma robdd_id_map_OK_D :
"⟦robdd_id_map_OK bs m; b ∈ subrobdds_set bs⟧ ⟹ m (robdd_get_id b) = Some b"
unfolding robdd_id_map_OK_def by blast
definition robdd_id_map where
"robdd_id_map bs i = Eps_Opt (λb. b ∈ subrobdds_set bs ∧ robdd_get_id b = i)"
lemma robdd_id_map_properties :
shows "robdd_invar_ids_equal bs ⟷ (robdd_id_map_OK bs (robdd_id_map bs))"
proof
assume ids_strong: "robdd_invar_ids_equal bs"
{ fix b1 b2
assume "b1 ∈ subrobdds_set bs"
with ids_strong
have "b2 ∈ subrobdds_set bs ∧ robdd_get_id b2 = robdd_get_id b1 ⟷ b2 = b1"
unfolding robdd_invar_ids_equal_def by metis
}
thus "robdd_id_map_OK bs (robdd_id_map bs)"
unfolding robdd_id_map_OK_def robdd_id_map_def
by simp
next
assume map_OK: "robdd_id_map_OK bs (robdd_id_map bs)"
show "robdd_invar_ids_equal bs"
unfolding robdd_invar_ids_equal_def
proof (intro allI impI iffI, elim conjE)
fix b1 b2
assume b1_in: "b1 ∈ subrobdds_set bs"
assume b2_in: "b2 ∈ subrobdds_set bs"
assume id_eq: "robdd_get_id b1 = robdd_get_id b2"
let ?P = "λb b'. b' ∈ subrobdds_set bs ∧ robdd_get_id b' = robdd_get_id b"
from map_OK b1_in b2_in have Eps_Opt_Eval: "Eps_Opt (?P b1) = Some b1" "Eps_Opt (?P b2) = Some b2"
unfolding robdd_id_map_OK_def robdd_id_map_def by simp_all
from id_eq have "?P b1 = ?P b2" by simp
with Eps_Opt_Eval show "b1 = b2" by (metis option.inject)
qed simp
qed
lemma robdd_id_map_union :
assumes invar_ids_bs12: "robdd_invar_ids_equal (bs1 ∪ bs2)"
shows "robdd_id_map (bs1 ∪ bs2) = (robdd_id_map bs1) ++ (robdd_id_map bs2)"
proof
fix i
from invar_ids_bs12
have invar_ids_bs1: "robdd_invar_ids_equal bs1"
and invar_ids_bs2: "robdd_invar_ids_equal bs2"
unfolding robdd_invar_ids_equal_def
by auto
from invar_ids_bs1 invar_ids_bs2 invar_ids_bs12 robdd_id_map_properties
have map_OK_bs1: "robdd_id_map_OK bs1 (robdd_id_map bs1)"
and map_OK_bs2: "robdd_id_map_OK bs2 (robdd_id_map bs2)"
and map_OK_bs12: "robdd_id_map_OK (bs1 ∪ bs2) (robdd_id_map (bs1 ∪ bs2))"
by simp_all
show "robdd_id_map (bs1 ∪ bs2) i = (robdd_id_map bs1 ++ robdd_id_map bs2) i"
proof (cases "∃b. b ∈ subrobdds_set (bs1 ∪ bs2) ∧ robdd_get_id b = i")
case False
hence "robdd_id_map (bs1 ∪ bs2) i = None" and
"robdd_id_map bs1 i = None" and
"robdd_id_map bs2 i = None"
unfolding robdd_id_map_def Eps_Opt_eq_None by auto
thus ?thesis by (simp add: map_add_find_left)
next
case True then obtain b where
b_in: "b ∈ subrobdds_set (bs1 ∪ bs2)"
and b_id: "robdd_get_id b = i" by auto
from map_OK_bs12 b_in b_id
have ls_eq: "robdd_id_map (bs1 ∪ bs2) i = Some b"
unfolding robdd_id_map_OK_def by metis
have rs_eq: "(robdd_id_map bs1 ++ robdd_id_map bs2) i = Some b"
proof (cases "b ∈ subrobdds_set bs2")
case True
with map_OK_bs2 b_id
have rs_eq2: "robdd_id_map bs2 i = Some b"
unfolding robdd_id_map_OK_def by metis
from ls_eq rs_eq2 show ?thesis by simp
next
case False note b_nin_bs2 = this
from b_in b_nin_bs2 have "b ∈ subrobdds_set bs1" by simp
with map_OK_bs1 b_id have rs_eq1: "robdd_id_map bs1 i = Some b"
unfolding robdd_id_map_OK_def by metis
from invar_ids_bs12 b_in b_nin_bs2 b_id have "⋀b'. b' ∈ subrobdds_set bs2 ⟹ robdd_get_id b' ≠ i"
unfolding robdd_invar_ids_equal_def by simp metis
hence rs_eq2: "robdd_id_map bs2 i = None"
unfolding robdd_id_map_def Eps_Opt_eq_None by auto
from ls_eq rs_eq1 rs_eq2 show ?thesis by (simp add: map_add_find_left)
qed
from ls_eq rs_eq show ?thesis by simp
qed
qed
subsection ‹Extended Boolean Operations›
text ‹For Boolean Operations on ROBDDs it is important to extend boolean operations
to option types. This allows to get the information that the result of the operation does
not depend on the value of some arguments.›
fun bool_op_extend :: "(bool ⇒ bool ⇒ bool) ⇒
(bool option ⇒ bool option ⇒ bool option)" where
"bool_op_extend bop None None =
(if ((bop True False = bop True True) ∧
(bop False True = bop True True) ∧
(bop False False = bop True True)) then Some (bop True True) else None)"
| "bool_op_extend bop None (Some b') =
(if (bop True b' ⟷ bop False b') then Some (bop False b') else None)"
| "bool_op_extend bop (Some b) None =
(if (bop b True ⟷ bop b False) then Some (bop b True) else None)"
| "bool_op_extend bop (Some b) (Some b') = Some (bop b b')"
text ‹Common Operations›
fun bope_neg where
"bope_neg None = None"
| "bope_neg (Some True) = Some False"
| "bope_neg (Some False) = (Some True)"
definition "bope_and = bool_op_extend (λx y. x ∧ y)"
definition "bope_or = bool_op_extend (λx y. x ∨ y)"
definition "bope_nand = bool_op_extend (λx y. ¬(x ∧ y))"
definition "bope_nor = bool_op_extend (λx y. ¬(x ∨ y))"
definition "bope_xor = bool_op_extend (λx y. x ≠ y)"
definition "bope_eq = bool_op_extend (λx y. x = y)"
definition "bope_imp = bool_op_extend (λx y. x ⟶ y)"
lemma bool_opt_exhaust:
"(y = None ⟹ P) ⟹ (y = Some True ⟹ P) ⟹ (y = Some False ⟹ P) ⟹ P"
by auto
lemma bope_and_code [code] :
"bope_and None None = None"
"bope_and bo (Some True) = bo"
"bope_and bo (Some False) = (Some False)"
"bope_and (Some True) bo = bo"
"bope_and (Some False) bo = (Some False)"
unfolding bope_and_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
lemma bope_or_code [code] :
"bope_or None None = None"
"bope_or bo (Some False) = bo"
"bope_or bo (Some True) = (Some True)"
"bope_or (Some False) bo = bo"
"bope_or (Some True) bo = (Some True)"
unfolding bope_or_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
lemma bope_nand_code [code] :
"bope_nand None None = None"
"bope_nand bo (Some False) = (Some True)"
"bope_nand (Some False) bo = (Some True)"
"bope_nand (Some True) (Some True) = (Some False)"
"bope_nand None (Some True) = None"
"bope_nand (Some True) None = None"
unfolding bope_nand_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
lemma bope_nor_code [code] :
"bope_nor None None = None"
"bope_nor bo (Some True) = (Some False)"
"bope_nor (Some True) bo = (Some False)"
"bope_nor (Some False) (Some False) = (Some True)"
"bope_nor None (Some False) = None"
"bope_nor (Some False) None = None"
unfolding bope_nor_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
lemma bope_eq_code [code] :
"bope_eq None bo = None"
"bope_eq bo None = None"
"bope_eq (Some True) (Some True) = Some True"
"bope_eq (Some True) (Some False) = Some False"
"bope_eq (Some False) (Some True) = Some False"
"bope_eq (Some False) (Some False) = Some True"
unfolding bope_eq_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
lemma bope_xor_code [code] :
"bope_xor None bo = None"
"bope_xor bo None = None"
"bope_xor (Some True) (Some True) = Some False"
"bope_xor (Some True) (Some False) = Some True"
"bope_xor (Some False) (Some True) = Some True"
"bope_xor (Some False) (Some False) = Some False"
unfolding bope_xor_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
lemma bope_imp_code [code] :
"bope_imp None None = None"
"bope_imp None (Some True) = Some True"
"bope_imp None (Some False) = None"
"bope_imp (Some True) bo = bo"
"bope_imp (Some False) bo = (Some True)"
unfolding bope_imp_def
apply (case_tac [!] bo rule: bool_opt_exhaust)
apply (simp_all)
done
subsection ‹Implementing boolean Combination›
text ‹For building boolean combinations of BDDs it is essential to use
a map storing already used IDs and a cache.
These datastructures cache can be implemented in different ways. Therefore, here the
needed properties are abstracted by using a locale.›
locale robdd_locale =
c: map_empty c_α c_invar c_empty +
c: map_lookup c_α c_invar c_lookup +
c: map_update c_α c_invar c_update +
r: map_empty r_α r_invar r_empty +
r: map_lookup r_α r_invar r_lookup +
r: map_update_dj r_α r_invar r_update
for c_α :: "'c_map ⇒ (nat × nat ⇒ robdd option)" and
c_invar c_empty c_lookup c_update and
r_α :: "'r_map ⇒ (nat × nat × nat ⇒ robdd option)" and
r_invar r_empty r_lookup r_update
begin
definition rev_map_invar where
"rev_map_invar bs rev_map = (r_invar (fst rev_map) ∧ snd rev_map > 1 ∧
(∀b ∈ subrobdds_set bs. robdd_invar_ext bs 0 b ∧ robdd_get_id b < (snd rev_map)) ∧
(∀li v ri b. r_α (fst rev_map) (li, v, ri) = Some b ⟶
(robdd_invar_ext bs v b ∧ b ∈ bs ∧
(∃l r i. b = robdd_var i l v r ∧
robdd_get_id l = li ∧ robdd_get_id r = ri))) ∧
(∀i l r v. robdd_var i l v r ∈ subrobdds_set bs ⟶
r_α (fst rev_map) (robdd_get_id l, v, robdd_get_id r) = Some (robdd_var i l v r)))"
lemma rev_map_invar_empty:
"rev_map_invar {} (r_empty(), 2)"
unfolding rev_map_invar_def by (simp add: r.empty_correct)
lemma rev_map_invarI[intro!] :
"⟦r_invar (fst rev_map); snd rev_map > 1;
⋀b. b ∈ subrobdds_set bs ⟹ robdd_invar_ext bs 0 b ∧ robdd_get_id b < (snd rev_map);
⋀li v ri b. r_α (fst rev_map) (li, v, ri) = Some b ⟹
(robdd_invar_ext bs v b ∧ b ∈ bs ∧
(∃l r i. b = robdd_var i l v r ∧
robdd_get_id l = li ∧ robdd_get_id r = ri));
⋀i l r v. robdd_var i l v r ∈ subrobdds_set bs ⟹
r_α (fst rev_map) (robdd_get_id l, v, robdd_get_id r) = Some (robdd_var i l v r)⟧ ⟹
rev_map_invar bs rev_map"
unfolding rev_map_invar_def by blast
lemma rev_map_invar_D1 :
assumes "rev_map_invar bs rev_map"
and "robdd_var i l v r ∈ subrobdds_set bs"
shows "r_α (fst rev_map) (robdd_get_id l, v, robdd_get_id r) = Some (robdd_var i l v r)"
using assms unfolding rev_map_invar_def by blast
lemma rev_map_invar_D2 :
assumes "rev_map_invar bs rev_map"
and "r_α (fst rev_map) (li, v, ri) = Some b"
shows "robdd_invar_ext bs v b ∧ b ∈ bs ∧
(∃l r i. b = robdd_var i l v r ∧
robdd_get_id l = li ∧ robdd_get_id r = ri)"
using assms unfolding rev_map_invar_def by blast
lemma rev_map_invar_D3 :
assumes "rev_map_invar bs rev_map"
and "b ∈ subrobdds_set bs"
shows "robdd_invar_ext bs 0 b" "robdd_get_id b < snd (rev_map)"
using assms unfolding rev_map_invar_def by blast+
lemma rev_map_invar_implies_invar_ids :
assumes invar: "rev_map_invar bs rev_map"
shows "robdd_invar_ids bs"
proof (cases "bs = {}")
case True thus ?thesis by (simp add: robdd_invar_ids_def subrobdds_set_def)
next
case False
then obtain b where "b ∈ bs" by auto
then have b_in: "b ∈ subrobdds_set bs"
unfolding subrobdds_set_def by rule simp
from rev_map_invar_D3(1)[OF invar b_in]
show ?thesis by (simp add: robdd_invar_ext_def)
qed
lemma rev_map_invar_implies_invar_bs :
assumes invar: "rev_map_invar bs rev_map"
and b_in: "b ∈ subrobdds_set bs"
shows "robdd_invar b"
using rev_map_invar_D3(1)[OF invar b_in]
by (rule robdd_invar_impl)
lemma rev_map_invar_implies_invar_ids_equal :
assumes invar: "rev_map_invar bs rev_map"
shows "robdd_invar_ids_equal bs"
proof -
note invar_ids = rev_map_invar_implies_invar_ids[OF invar]
note bs_OK_full = rev_map_invar_implies_invar_bs[OF invar]
have bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar b"
by (metis bs_OK_full subrobdds_set_mono subsetD)
show "robdd_invar_ids_equal bs"
by (rule robdd_invar_ids_equal_intro [OF bs_OK invar_ids])
qed
definition robdd_construct :: "'r_map × node_id ⇒ robdd ⇒ var ⇒ robdd ⇒ robdd × ('r_map × node_id)" where
"robdd_construct rev_map l v r =
(let l_id = robdd_get_id l in
let r_id = robdd_get_id r in
(if l_id = r_id then (l, rev_map) else
(case r_lookup (l_id, v, r_id) (fst rev_map) of
Some b ⇒ (b, rev_map)
| None ⇒ (let b = robdd_var (snd rev_map) l v r in
(b, (r_update (l_id, v, r_id) b (fst rev_map), Suc (snd rev_map)))))))"
lemma robdd_construct_correct :
fixes l v r bs rev_map
defines "res ≡ robdd_construct rev_map l v r"
defines "rev_map' ≡ (snd res)"
defines "b ≡ fst res"
defines "bs' ≡ insert b bs"
assumes invar_rev_map: "rev_map_invar bs rev_map"
and lr_in: "l ∈ bs" "r ∈ bs"
and invar_lr: "robdd_invar_ext bs (Suc v) l" "robdd_invar_ext bs (Suc v) r"
shows "robdd_invar_ext bs' v b ∧ rev_map_invar bs' rev_map' ∧
robdd_α b = robdd_α (robdd_var 0 l v r)"
proof -
define l_id where "l_id = robdd_get_id l"
define r_id where "r_id = robdd_get_id r"
note bs_OK = rev_map_invar_implies_invar_bs[OF invar_rev_map]
from invar_lr have invar_ids: "robdd_invar_ids bs"
and lr_in': "l ∈ subrobdds_set bs" "r ∈ subrobdds_set bs"
unfolding robdd_invar_ext_def by simp_all
from robdd_invar_ids_equal_intro[of bs, OF bs_OK invar_ids]
subrobdds_set_mono[of bs]
have invar_ids_equal: "robdd_invar_ids_equal bs" by (simp add: subset_iff)
from invar_rev_map have r_invar: "r_invar (fst rev_map)" unfolding rev_map_invar_def by simp
show ?thesis
proof (cases "l_id = r_id")
case True note l_id_eq = this
from lr_in' invar_ids l_id_eq have l_α: "robdd_α l = robdd_α r"
unfolding robdd_invar_ids_def l_id_def r_id_def by simp
from invar_lr(1) have invar_l': "robdd_invar_ext bs v l"
apply (rule robdd_invar_ext_weaken_var)
apply (simp)
done
from lr_in(1) have bs'_eq: "insert l bs = bs" by auto
from res_def l_id_eq show ?thesis
unfolding robdd_construct_def l_id_def[symmetric] r_id_def[symmetric]
b_def bs'_def rev_map'_def
by (simp add: fun_eq_iff l_α bs'_eq invar_lr(1) invar_rev_map invar_l')
next
case False note l_id_neq = this
show ?thesis
proof (cases "r_lookup (l_id, v, r_id) (fst rev_map)")
case (Some b) note map_eq = this
from r_invar rev_map_invar_D2[OF invar_rev_map, of l_id v r_id b] map_eq
obtain l' r' i where
invar_b: "robdd_invar_ext bs v b" and
b_in: "b ∈ bs" and
b_eq: "b = robdd_var i l' v r'" and
l_id_eq: "robdd_get_id l' = l_id" and
r_id_eq: "robdd_get_id r' = r_id"
unfolding rev_map_invar_def by (auto simp add: r.lookup_correct)
from b_in have bs'_eq: "insert b bs = bs" by auto
have b_α: "robdd_α b = robdd_α (robdd_var 0 l' v r')"
unfolding b_eq by (simp add: fun_eq_iff)
have lr'_eq: "l' = l" "r' = r"
proof -
from b_in b_eq have lr'_in': "l' ∈ subrobdds_set bs" "r' ∈ subrobdds_set bs"
apply (simp_all add: subrobdds_set_def)
apply (auto intro: bexI [of _ b])
done
from invar_ids_equal lr_in' lr'_in' l_id_eq r_id_eq
show "l' = l" "r' = r"
unfolding robdd_invar_ids_equal_def l_id_def r_id_def by auto
qed
from res_def l_id_neq show ?thesis
unfolding robdd_construct_def l_id_def[symmetric] r_id_def[symmetric]
bs'_def rev_map'_def b_def
by (simp add: map_eq bs'_eq invar_b b_α lr'_eq invar_rev_map)
next
case None note map_eq = this
define b' where "b' = robdd_var (snd rev_map) l v r"
have α_b': "robdd_α b' = robdd_α (robdd_var 0 l v r)"
unfolding b'_def by (simp add: fun_eq_iff)
from lr_in' invar_ids l_id_neq have "robdd_α l ≠ robdd_α r"
unfolding robdd_invar_ids_def l_id_def r_id_def by simp
with robdd_equiv_implies_sem_equiv[of l r] have l_not_equiv: "~(robdd_equiv l r)" by blast
from invar_lr
have b'_invar_vars: "robdd_invar_vars b'" and b'_invar_reduced: "robdd_invar_reduced b'"
unfolding b'_def robdd_invar_vars_def
by (simp_all add: robdd_invar_ext_def l_not_equiv)
{ fix b2
assume b2_in: "b2 ∈ subrobdds_set bs"
from rev_map_invar_D3[OF invar_rev_map b2_in]
have id_neq: "robdd_get_id b2 ≠ robdd_get_id b'"
unfolding b'_def by simp
have invar_b2: "robdd_invar b2" by (metis b2_in bs_OK)
have α_b2: "robdd_α b2 ≠ robdd_α b'"
proof (rule notI)
assume sem_eq: "robdd_α b2 = robdd_α b'"
with invar_b2 robdd_equiv_alt_def_full[OF b'_invar_vars b'_invar_reduced, of b2]
have "robdd_equiv b' b2" by (metis robdd_invar_alt_def)
then obtain i' l' r' where
b2_eq: "b2 = robdd_var i' l' v r'" and
l'_equiv: "robdd_equiv l l'" and
r'_equiv: "robdd_equiv r r'"
unfolding b'_def by auto
have r'_eq[simp]: "r' = r" and l'_eq[simp]: "l' = l"
proof -
have "l' ∈ subrobdds b2" "r' ∈ subrobdds b2"
unfolding b2_eq by simp_all
with b2_in have "l' ∈ subrobdds_set bs" "r' ∈ subrobdds_set bs"
by (metis subrobdds_set_subset_simp subsetD)+
with robdd_invar_ids_equiv_implies_eq[of "subrobdds_set bs" l l']
robdd_invar_ids_equiv_implies_eq[of "subrobdds_set bs" r r']
show "r' = r" "l' = l"
by (simp_all add: l'_equiv r'_equiv robdd_invar_ids_expand invar_ids lr_in')
qed
from rev_map_invar_D1[OF invar_rev_map b2_in[unfolded b2_eq]] map_eq
show "False" by (simp add: l_id_def r_id_def r.lookup_correct r_invar)
qed
note invar_b2 α_b2 id_neq
} note in_bs_b'_props = this
have subrobdds_set_bs_simp: "subrobdds_set (insert b' bs) = insert b' (subrobdds_set bs)"
unfolding subrobdds_set_def b'_def using lr_in
by (auto simp add: set_eq_iff Bex_def)
have invar_ids': "robdd_invar_ids (insert b' bs)"
proof (rule robdd_invar_idsI)
fix b1 b2
assume b1_in: "b1 ∈ subrobdds_set (insert b' bs)" and
b2_in: "b2 ∈ subrobdds_set (insert b' bs)"
from b1_in b2_in
show "(robdd_α b1 = robdd_α b2) = (robdd_get_id b1 = robdd_get_id b2)"
unfolding subrobdds_set_bs_simp
using robdd_invar_idsD[OF invar_ids, of b1 b2] in_bs_b'_props
by simp metis
qed
from invar_ids' b'_invar_reduced b'_invar_vars
have invar_b': "robdd_invar_ext (insert b' bs) v b'"
by (simp add: robdd_invar_ext_def robdd_invar_vars_def b'_def)
have invar_rev_map': "rev_map_invar bs' rev_map'"
proof -
let ?rm = "(r_update (l_id, v, r_id) b' (fst rev_map), Suc (snd rev_map))"
have "rev_map_invar (insert b' bs) ?rm"
proof
from map_eq
show "r_invar (fst ?rm)"
apply (simp)
apply (rule r.update_dj_correct)
apply (simp_all add: r_invar r.lookup_correct dom_def)
done
next
from invar_rev_map
show "1 < snd ?rm" unfolding rev_map_invar_def by simp
next
fix b
assume b_in: "b ∈ subrobdds_set (insert b' bs)"
show "robdd_invar_ext (insert b' bs) 0 b ∧ robdd_get_id b < snd ?rm"
proof (cases "b = b'")
case True with invar_b' show ?thesis unfolding b'_def by simp
next
case False
with subrobdds_set_bs_simp b_in
have b_in': "b ∈ subrobdds_set bs" by simp
from rev_map_invar_D3[OF invar_rev_map b_in']
show ?thesis by (simp add: robdd_invar_ext_def invar_ids')
qed
next
fix i l r v'
assume b_in: "robdd_var i l v' r ∈ subrobdds_set (insert b' bs)"
show "r_α (fst ?rm) (robdd_get_id l, v', robdd_get_id r) =
Some (robdd_var i l v' r)"
proof (cases "robdd_var i l v' r = b'")
case True with map_eq show ?thesis
by (simp add: b'_def l_id_def[symmetric] r_id_def[symmetric]
r.lookup_correct r_invar dom_def r.update_dj_correct)
next
case False
with subrobdds_set_bs_simp b_in
have b_in': "robdd_var i l v' r ∈ subrobdds_set bs" by simp
from rev_map_invar_D1[OF invar_rev_map b_in'] map_eq
show ?thesis by (auto simp add: r.lookup_correct r.update_dj_correct dom_def r_invar)
qed
next
fix li v' ri b
assume b_intro: "r_α (fst ?rm) (li, v', ri) = Some b"
show "robdd_invar_ext (insert b' bs) v' b ∧ b ∈ insert b' bs ∧
(∃l r i. b = robdd_var i l v' r ∧ robdd_get_id l = li ∧ robdd_get_id r = ri)"
proof (cases "(li, v', ri) = (robdd_get_id l, v, robdd_get_id r)")
case True note lriv'_eq = this
with b_intro map_eq have b_eq: "b = b'"
by (simp_all add: r.update_dj_correct dom_def r.lookup_correct r_invar l_id_def r_id_def)
with lriv'_eq show ?thesis
apply (simp add: invar_b')
apply (simp add: b'_def)
done
next
case False
with b_intro map_eq have b_intro': "r_α (fst rev_map) (li, v', ri) = Some b"
by (auto simp add: r.lookup_correct r.update_dj_correct dom_def r_invar l_id_def r_id_def)
from rev_map_invar_D2[OF invar_rev_map b_intro']
show ?thesis
apply simp
apply (simp add: robdd_invar_ext_def invar_ids')
done
qed
qed
thus ?thesis
unfolding bs'_def rev_map'_def res_def robdd_construct_def l_id_def[symmetric]
r_id_def[symmetric] b_def
by (simp add: map_eq b'_def[symmetric] α_b' invar_b' l_id_neq)
qed
from res_def l_id_neq invar_rev_map'
show ?thesis
unfolding robdd_construct_def l_id_def[symmetric] r_id_def[symmetric]
bs'_def rev_map'_def b_def
by (simp add: map_eq b'_def[symmetric] α_b' invar_b' )
qed
qed
qed
fun (in -) robdd_apply_next where
"robdd_apply_next (robdd_leaf f) (robdd_leaf f') =
(robdd_leaf f, robdd_leaf f, 0, robdd_leaf f', robdd_leaf f')"
| "robdd_apply_next (robdd_leaf f) (robdd_var i l v r) = (robdd_leaf f, robdd_leaf f, v, l, r)"
| "robdd_apply_next (robdd_var i l v r) (robdd_leaf f) = (l, r, v, robdd_leaf f, robdd_leaf f)"
| "robdd_apply_next (robdd_var i l v r) (robdd_var i' l' v' r') =
(if v < v' then
(l, r, v, (robdd_var i' l' v' r'), (robdd_var i' l' v' r'))
else (if v = v' then
(l, r, v, l', r')
else
((robdd_var i l v r), (robdd_var i l v r), v', l', r')))"
definition (in -) robdd_neg_next where
"robdd_neg_next b = (let (l, r, v, _, _) = robdd_apply_next b robdd_one in (l, r, v))"
lemma (in -) robdd_neg_simps[code, simp] :
"robdd_neg_next (robdd_leaf f) =
(robdd_leaf f, robdd_leaf f, 0)"
"robdd_neg_next (robdd_var i l v r) = (l, r, v)"
unfolding robdd_neg_next_def by simp_all
fun (in -) robdd_get_min_var where
"robdd_get_min_var (robdd_leaf _) (robdd_leaf _) = 0"
| "robdd_get_min_var (robdd_leaf _) (robdd_var _ _ v _) = v"
| "robdd_get_min_var (robdd_var _ _ v _) (robdd_leaf _) = v"
| "robdd_get_min_var (robdd_var _ _ v1 _) (robdd_var _ _ v2 _) = (if v1 ≤ v2 then v1 else v2)"
lemma (in -) robdd_apply_next_correct :
assumes invar_b1: "robdd_invar_ext bs1 n1 b1"
and invar_b2: "robdd_invar_ext bs2 n2 b2"
and eval: "robdd_apply_next b1 b2 = (b1_l, b1_r, v'', b2_l, b2_r)"
shows "robdd_α b1_l = (λa. robdd_α b1 (a (v'' := True)))" (is ?T1)
"robdd_α b1_r = (λa. robdd_α b1 (a (v'' := False)))" (is ?T2)
"robdd_α b2_l = (λa. robdd_α b2 (a (v'' := True)))" (is ?T3)
"robdd_α b2_r = (λa. robdd_α b2 (a (v'' := False)))" (is ?T4)
"robdd_invar_ext bs1 (Suc v'') b1_l" (is ?T5)
"robdd_invar_ext bs1 (Suc v'') b1_r" (is ?T6)
"robdd_invar_ext bs2 (Suc v'') b2_l" (is ?T7)
"robdd_invar_ext bs2 (Suc v'') b2_r" (is ?T8)
"b1_l ∈ subrobdds b1" (is ?T9)
"b2_l ∈ subrobdds b2" (is ?T10)
"b1_r ∈ subrobdds b1" (is ?T11)
"b2_r ∈ subrobdds b2" (is ?T12)
"robdd_get_min_var b1 b2 = v''" (is ?T13)
"~(robdd_is_leaf b1 ∧ robdd_is_leaf b2) ⟶
size_robdd b1_l + size_robdd b2_l < size_robdd b1 + size_robdd b2" (is ?T14)
"~(robdd_is_leaf b1 ∧ robdd_is_leaf b2) ⟶
size_robdd b1_r + size_robdd b2_r < size_robdd b1 + size_robdd b2" (is ?T15)
proof -
have "?T1 ∧ ?T2 ∧ ?T3 ∧ ?T4 ∧ ?T5 ∧ ?T6 ∧ ?T7 ∧ ?T8 ∧ ?T9 ∧ ?T10 ∧ ?T11 ∧ ?T12 ∧ ?T13 ∧ ?T14 ∧ ?T15"
proof (cases b1)
case (robdd_leaf f) note b1_eq = this
show ?thesis
proof (cases b2)
case (robdd_leaf f') note b2_eq = this
with b1_eq eval[symmetric] invar_b1 invar_b2 show ?thesis by (simp add: fun_eq_iff)
next
case (robdd_var i' l' v' r') note b2_eq = this
with b1_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
apply (simp add: fun_eq_iff)
apply (intro allI conjI robdd_α_invar_greater [of "Suc v'"])
apply (simp_all add: robdd_invar_ext_def)
done
qed
next
case (robdd_var i l v r) note b1_eq = this
show ?thesis
proof (cases b2)
case (robdd_leaf f') note b2_eq = this
with b1_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
apply (simp add: fun_eq_iff)
apply (intro allI conjI robdd_α_invar_greater [of "Suc v"])
apply (simp_all add: robdd_invar_ext_def)
done
next
case (robdd_var i' l' v' r') note b2_eq = this
show ?thesis
proof (cases "v < v'")
case True
with robdd_invar_vars_greater___weaken[of "Suc v'" _ "Suc v"] b1_eq b2_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
apply (simp add: fun_eq_iff)
apply (intro allI conjI impI robdd_α_invar_greater [of "Suc v''"])
apply (simp_all add: robdd_invar_ext_def)
done
next
case False hence v'_le: "v' ≤ v" by simp
show ?thesis
proof (cases "v = v'")
case True
with robdd_invar_vars_greater___weaken[of "Suc v'" _ "Suc v"] b1_eq b2_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
apply (simp add: fun_eq_iff)
apply (intro allI conjI impI robdd_α_invar_greater [of "Suc v''"])
apply (simp_all add: robdd_invar_ext_def)
done
next
case False
with v'_le have "v' < v" by simp
with robdd_invar_vars_greater___weaken[of "Suc v" _ "Suc v'"] b1_eq b2_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
apply (simp add: fun_eq_iff)
apply (intro allI conjI impI robdd_α_invar_greater [of "Suc v''"])
apply (simp_all add: robdd_invar_ext_def)
done
qed
qed
qed
qed
thus ?T1 ?T2 ?T3 ?T4 ?T5 ?T6 ?T7 ?T8 ?T9 ?T10 ?T11 ?T12 ?T13 ?T14 ?T15 by auto
qed
function robdd_apply where
"robdd_apply apply_map rev_map bop b1 b2 =
(case (bool_op_extend bop (robdd_to_bool b1) (robdd_to_bool b2)) of
Some f ⇒ (robdd_leaf f, apply_map, rev_map)
| None ⇒ (case c_lookup (robdd_get_id b1, robdd_get_id b2) apply_map of
Some b3 ⇒ (b3, apply_map, rev_map)
| None ⇒ (let (l1, r1, var, l2, r2) = robdd_apply_next b1 b2 in
let (l, apply_map, rev_map) = robdd_apply apply_map rev_map bop l1 l2 in
let (r, apply_map, rev_map) = robdd_apply apply_map rev_map bop r1 r2 in
let (b, rev_map) = robdd_construct rev_map l var r in
let apply_map = c_update (robdd_get_id b1, robdd_get_id b2) b apply_map in
(b, apply_map, rev_map))))"
by pat_completeness auto
termination
apply (relation "measure (λ(_, _, _, b1, b2). size_robdd b1 + size_robdd b2)")
apply simp
apply (clarify, simp)
defer
apply (clarify, simp)
proof -
fix b1 b2 l1 l2 r1 r2 v bop
assume bop_eq: "bool_op_extend bop (robdd_to_bool b1) (robdd_to_bool b2) = None"
and next_eq: "(l1, r1, v, l2, r2) = robdd_apply_next b1 b2"
hence "size_robdd l1 + size_robdd l2 < size_robdd b1 + size_robdd b2 ∧
size_robdd r1 + size_robdd r2 < size_robdd b1 + size_robdd b2"
apply (case_tac [!] b1)
apply (case_tac [!] b2)
apply (simp_all split: if_splits)
done
thus "size_robdd l1 + size_robdd l2 < size_robdd b1 + size_robdd b2"
"size_robdd r1 + size_robdd r2 < size_robdd b1 + size_robdd b2" by simp_all
qed
declare robdd_apply.simps[simp del]
definition apply_map_invar where
"apply_map_invar bop bs bs1 bs2 apply_map ⟷
c_invar apply_map ∧
(∀i1 i2 b. c_lookup (i1, i2) apply_map = Some b ⟶
(∃b1 b2. robdd_id_map bs1 i1 = Some b1 ∧ robdd_id_map bs2 i2 = Some b2 ∧
robdd_invar_ext bs (robdd_get_min_var b1 b2) b ∧ (∀a. robdd_α b a ⟷ bop (robdd_α b1 a) (robdd_α b2 a))))"
lemma apply_map_invar_empty :
"apply_map_invar bop bs bs1 bs2 (c_empty ())"
unfolding apply_map_invar_def by (simp add: c.empty_correct c.lookup_correct)
lemma apply_map_invar_I :
"⟦c_invar apply_map;
⋀i1 i2 b. c_lookup (i1, i2) apply_map = Some b ⟹
∃b1 b2. robdd_id_map bs1 i1 = Some b1 ∧ robdd_id_map bs2 i2 = Some b2 ∧
robdd_invar_ext bs (robdd_get_min_var b1 b2) b ∧ (∀a. robdd_α b a ⟷ bop (robdd_α b1 a) (robdd_α b2 a))⟧ ⟹
apply_map_invar bop bs bs1 bs2 apply_map"
unfolding apply_map_invar_def by blast
lemma apply_map_invar_D1 :
"apply_map_invar bop bs bs1 bs2 apply_map ⟹ c_invar apply_map"
unfolding apply_map_invar_def by blast
lemma apply_map_invar_D2 :
"⟦apply_map_invar bop bs bs1 bs2 apply_map;
c_lookup (i1, i2) apply_map = Some b⟧ ⟹
∃b1 b2. robdd_id_map bs1 i1 = Some b1 ∧ robdd_id_map bs2 i2 = Some b2 ∧
robdd_invar_ext bs (robdd_get_min_var b1 b2) b ∧ (∀a. robdd_α b a ⟷ bop (robdd_α b1 a) (robdd_α b2 a))"
unfolding apply_map_invar_def by blast
lemma apply_map_invar_extend :
assumes invar: "apply_map_invar bop bs bs1 bs2 apply_map"
and bs1'_OK: "bs1 ⊆ bs1'" "robdd_invar_ids bs1'" "⋀b. b ∈ bs1' ⟹ robdd_invar b"
and bs2'_OK: "bs2 ⊆ bs2'" "robdd_invar_ids bs2'" "⋀b. b ∈ bs2' ⟹ robdd_invar b"
shows "apply_map_invar bop bs bs1' bs2' apply_map"
proof (rule apply_map_invar_I, goal_cases)
case 1
thus ?case using apply_map_invar_D1[OF invar] .
next
case lookup_eq: (2 i1 i2 b)
from apply_map_invar_D2[OF invar lookup_eq]
obtain b1 b2 where
id_map_bs1: "robdd_id_map bs1 i1 = Some b1" and
id_map_bs2: "robdd_id_map bs2 i2 = Some b2" and
invar_b: "robdd_invar_ext bs (robdd_get_min_var b1 b2) b" and
sem_b: "∀a. robdd_α b a = bop (robdd_α b1 a) (robdd_α b2 a)"
by blast
from bs1'_OK(1) obtain bs1'' where bs1'_eq: "bs1' = bs1'' ∪ bs1" by auto
from bs2'_OK(1) obtain bs2'' where bs2'_eq: "bs2' = bs2'' ∪ bs2" by auto
from robdd_invar_ids_equal_intro [OF bs1'_OK(3) bs1'_OK(2)] bs1'_eq
have ids_equal_bs1': "robdd_invar_ids_equal (bs1'' ∪ bs1)" by simp
from robdd_invar_ids_equal_intro [OF bs2'_OK(3) bs2'_OK(2)] bs2'_eq
have ids_equal_bs2': "robdd_invar_ids_equal (bs2'' ∪ bs2)" by simp
show ?case
apply (rule_tac exI[where x = b1])
apply (rule_tac exI[where x = b2])
apply (simp add: invar_b sem_b bs1'_eq bs2'_eq
robdd_id_map_union [OF ids_equal_bs1']
robdd_id_map_union [OF ids_equal_bs2']
map_add_Some_iff id_map_bs1 id_map_bs2)
done
qed
lemma robdd_apply_correct_full :
fixes b1 b2 bop rev_map apply_map bs
defines "res ≡ robdd_apply apply_map rev_map bop b1 b2"
defines "b ≡ fst res"
defines "apply_map' ≡ fst (snd res)"
defines "rev_map' ≡ snd (snd res)"
assumes invar_rev_map: "rev_map_invar bs rev_map"
and invar_apply_map: "apply_map_invar bop bs bs1 bs2 apply_map"
and b1_invar: "robdd_invar_ext bs1 n b1"
and b2_invar: "robdd_invar_ext bs2 n b2"
and bs1_OK: "⋀b. b ∈ bs1 ⟹ robdd_invar b"
and bs2_OK: "⋀b. b ∈ bs2 ⟹ robdd_invar b"
shows "∃bs'.
subrobdds b ∪ bs ⊆ bs' ∧
robdd_invar_ext bs' n b ∧
apply_map_invar bop bs' bs1 bs2 apply_map' ∧
rev_map_invar bs' rev_map' ∧
(∀a. robdd_α b a ⟷ bop (robdd_α b1 a) (robdd_α b2 a))"
using invar_rev_map invar_apply_map b1_invar b2_invar
unfolding b_def apply_map'_def rev_map'_def res_def
proof (induct "(b1, b2)" arbitrary: b1 b2 bs n apply_map rev_map rule: measure_induct_rule [of "λ(b1, b2). size_robdd b1 + size_robdd b2"])
case less
note indhyp = less(1)
note invar_rev_map = less(2)
note invar_apply_map = less(3)
note b1_invar = less(4)
note b2_invar = less(5)
let ?res = "robdd_apply apply_map rev_map bop b1 b2"
note res_def = robdd_apply.simps [of apply_map rev_map bop b1 b2]
from rev_map_invar_implies_invar_ids[OF invar_rev_map]
have invar_ids_bs: "robdd_invar_ids bs" by simp
note bs_OK_full = rev_map_invar_implies_invar_bs[OF invar_rev_map]
have bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar b" by (metis bs_OK_full subrobdds_set_mono subsetD)
from b1_invar have b1_in: "b1 ∈ subrobdds_set bs1" unfolding robdd_invar_ext_def by simp
from b2_invar have b2_in: "b2 ∈ subrobdds_set bs2" unfolding robdd_invar_ext_def by simp
from b1_invar have invar_ids_bs1: "robdd_invar_ids bs1" unfolding robdd_invar_ext_def by simp
from b2_invar have invar_ids_bs2: "robdd_invar_ids bs2" unfolding robdd_invar_ext_def by simp
have invar_ids_equal_bs1: "robdd_invar_ids_equal bs1"
by (rule robdd_invar_ids_equal_intro [OF bs1_OK invar_ids_bs1])
have invar_ids_equal_bs2: "robdd_invar_ids_equal bs2"
by (rule robdd_invar_ids_equal_intro [OF bs2_OK invar_ids_bs2])
have invar_ids_leafs_bs : "robdd_invar_ids_leafs bs"
proof (rule robdd_invar_ids_leafs_intro[of bs, OF _ invar_ids_bs])
fix b
assume "b ∈ bs"
with bs_OK[of b] have "robdd_invar b" by simp
thus "robdd_invar_reduced b" unfolding robdd_invar_def robdd_invar_ext_def by simp
qed
show "∃bs'. subrobdds (fst ?res) ∪ bs ⊆ bs' ∧
robdd_invar_ext bs' n (fst ?res) ∧
apply_map_invar bop bs' bs1 bs2 (fst (snd ?res)) ∧
rev_map_invar bs' (snd (snd ?res)) ∧
(∀a. robdd_α (fst ?res) a = bop (robdd_α b1 a) (robdd_α b2 a))"
(is "∃bs'. ?P bs'")
proof (cases "bool_op_extend bop (robdd_to_bool b1) (robdd_to_bool b2)")
case (Some f) note extend_eq_Some = this
have res_eq[simp]: "?res = (robdd_leaf f, apply_map, rev_map)"
using res_def
by (simp add: extend_eq_Some)
from extend_eq_Some have f_eq: "∀a. f = bop (robdd_α b1 a) (robdd_α b2 a)"
apply (case_tac b1, case_tac [!] b2)
apply (simp_all split: if_splits)
apply (auto, (metis(full_types))+)
done
from invar_ids_leafs_bs invar_ids_bs
have invar_ids_bs': "robdd_invar_ids (insert (robdd_leaf f) bs)"
apply (simp add: robdd_invar_ids_leafs_def robdd_invar_ids_def)
apply (intro allI impI)
apply (elim conjE disjE)
apply (simp_all)
apply (metis One_nat_def)
done
have invar_ids_equal_bs': "robdd_invar_ids_equal (insert (robdd_leaf f) bs)"
apply (rule robdd_invar_ids_equal_intro [OF _ invar_ids_bs'])
apply (auto simp add: bs_OK)
done
from invar_rev_map invar_ids_bs'
have invar_rev_map': "rev_map_invar (insert (robdd_leaf f) bs) rev_map"
unfolding rev_map_invar_def by (simp add: robdd_invar_ext_def)
from robdd_id_map_union [of "{robdd_leaf f}" bs] invar_ids_equal_bs'
have id_map'_eq: "robdd_id_map (insert (robdd_leaf f) bs) = robdd_id_map {robdd_leaf f} ++ robdd_id_map bs"
by simp
from invar_apply_map
have invar_apply_map': "apply_map_invar bop (insert (robdd_leaf f) bs) bs1 bs2 apply_map"
unfolding apply_map_invar_def robdd_invar_ext_def invar_ids_equal_bs'
by (simp add: invar_ids_bs') metis
have "?P (insert (robdd_leaf f) bs)" by (simp add: invar_ids_bs' f_eq invar_rev_map' invar_apply_map')
thus ?thesis by blast
next
case None note extend_eq_None = this
have min_var_b12_ge_n: "(robdd_get_min_var b1 b2) ≥ n"
proof -
from b1_invar b2_invar have "robdd_invar_vars_greater n b1 ∧ robdd_invar_vars_greater n b2"
unfolding robdd_invar_ext_def by simp_all
with extend_eq_None show "(robdd_get_min_var b1 b2) ≥ n"
by (cases b1, case_tac [!] b2, simp_all)
qed
show ?thesis
proof (cases "c_lookup (robdd_get_id b1, robdd_get_id b2) apply_map")
case (Some b3) note lookup_eq_Some = this
from extend_eq_None lookup_eq_Some res_def
have res_eq[simp]: "?res = (b3, apply_map, rev_map)"
by simp
from apply_map_invar_D2[OF invar_apply_map, OF lookup_eq_Some]
robdd_id_map_properties[of bs1] invar_ids_equal_bs1
robdd_id_map_properties[of bs2] invar_ids_equal_bs2
b1_in b2_in
have invar_b3: "robdd_invar_ext bs (robdd_get_min_var b1 b2) b3" and
sem_b3: "⋀a. robdd_α b3 a = bop (robdd_α b1 a) (robdd_α b2 a)"
by (simp_all add: robdd_id_map_OK_def)
from invar_b3 have b3_in: "b3 ∈ subrobdds_set bs" unfolding robdd_invar_ext_def by simp
hence subrobdds_b3_bs_eq: "subrobdds_set (subrobdds b3 ∪ bs) = subrobdds_set bs"
using subrobdds_set_subset_simp[of b3 bs] by auto
from subrobdds_b3_bs_eq invar_b3
have invar_b3': "robdd_invar_ext (subrobdds b3 ∪ bs) n b3"
unfolding robdd_invar_ext_def
using robdd_invar_ids_expand[of "subrobdds b3 ∪ bs", symmetric]
robdd_invar_ids_expand[of bs]
robdd_invar_vars_greater___weaken[OF _ min_var_b12_ge_n, of b3] by simp
from invar_b3' have invar_ids': "robdd_invar_ids (subrobdds b3 ∪ bs)"
unfolding robdd_invar_ext_def by simp
from invar_rev_map invar_ids'
have invar_rev_map': "rev_map_invar (subrobdds b3 ∪ bs) rev_map"
unfolding rev_map_invar_def subrobdds_b3_bs_eq robdd_invar_ext_def
by simp
from invar_apply_map invar_ids'
have invar_apply_map': "apply_map_invar bop (subrobdds b3 ∪ bs) bs1 bs2 apply_map"
unfolding apply_map_invar_def robdd_invar_ext_def by simp blast
have "?P (subrobdds b3 ∪ bs)" by (simp add: invar_b3' sem_b3 invar_rev_map' invar_apply_map')
thus ?thesis by blast
next
case None note lookup_eq_None = this
from extend_eq_None have not_leaf_b12: "~(robdd_is_leaf b1 ∧ robdd_is_leaf b2)"
by (cases b1, case_tac [!] b2) simp_all
obtain b1_l b1_r v'' b2_l b2_r where
next_eq: "robdd_apply_next b1 b2 = (b1_l, b1_r, v'', b2_l, b2_r)" by (metis prod.exhaust)
obtain l apply_map' rev_map' where
apply_l_eq: "robdd_apply apply_map rev_map bop b1_l b2_l = (l, apply_map', rev_map')"
by (metis prod.exhaust)
obtain r apply_map'' rev_map'' where
apply_r_eq: "robdd_apply apply_map' rev_map' bop b1_r b2_r = (r, apply_map'', rev_map'')"
by (metis prod.exhaust)
obtain b' rev_map''' where const_eq: "robdd_construct rev_map'' l v'' r = (b', rev_map''')"
by (metis prod.exhaust)
define apply_map'''
where "apply_map''' = c_update (robdd_get_id b1, robdd_get_id b2) b' apply_map''"
note next_props = robdd_apply_next_correct [OF b1_invar b2_invar next_eq] not_leaf_b12
note v''_eq = next_props(13)
have res_eq[simp]: "?res =(b', apply_map''', rev_map''')"
by (simp_all add: b_def next_eq res_def extend_eq_None lookup_eq_None apply_r_eq apply_l_eq
const_eq apply_map'_def apply_map'''_def rev_map'_def)
from indhyp [of b1_l b2_l bs rev_map apply_map "Suc v''"]
obtain bs' where
subset_bs': "subrobdds l ∪ bs ⊆ bs'" and
l_invar0: "robdd_invar_ext bs' (Suc v'') l" and
invar_apply_map': "apply_map_invar bop bs' bs1 bs2 apply_map'" and
invar_rev_map': "rev_map_invar bs' rev_map'" and
sem_l: "∀a. robdd_α l a = bop (robdd_α b1 (a(v'' := True)))
(robdd_α b2 (a(v'' := True)))"
by (simp add: apply_l_eq next_props invar_rev_map invar_apply_map) metis
from indhyp [of b1_r b2_r bs' rev_map' apply_map' "Suc v''"]
obtain bs'' where
subset_bs'': "subrobdds r ∪ bs' ⊆ bs''" and
r_invar1: "robdd_invar_ext bs'' (Suc v'') r" and
invar_apply_map'': "apply_map_invar bop bs'' bs1 bs2 apply_map''" and
invar_rev_map'': "rev_map_invar bs'' rev_map''" and
sem_r: "∀a. robdd_α r a = bop (robdd_α b1 (a(v'' := False)))
(robdd_α b2 (a(v'' := False)))"
by (simp add: apply_r_eq next_props invar_rev_map' invar_apply_map') metis
from subset_bs' have "l ∈ bs'" by auto
with subset_bs'' have l_in_bs'': "l ∈ bs''" by auto
from subset_bs'' have r_in_bs'': "r ∈ bs''" by auto
from l_invar0 r_invar1 l_in_bs''
have l_invar1: "robdd_invar_ext bs'' (Suc v'') l"
unfolding robdd_invar_ext_def by simp (metis subrobdds_set_mono subsetD)
define bs''' where "bs''' = insert b' bs''"
from robdd_construct_correct[OF invar_rev_map'' _ _ l_invar1 r_invar1]
have b'_invar: "robdd_invar_ext bs''' v'' b'"
and invar_rev_map''': "rev_map_invar bs''' rev_map'''"
and sem_b': "robdd_α b' = robdd_α (robdd_var 0 l v'' r)"
by (simp_all add: const_eq bs'''_def l_in_bs'' r_in_bs'')
have sem_OK: "∀a. robdd_α b' a = bop (robdd_α b1 a) (robdd_α b2 a)"
by (simp add: sem_b' sem_l sem_r fun_upd_idem)
have "?P (subrobdds_set bs''')"
unfolding res_eq fst_conv snd_conv
proof (intro conjI)
from subset_bs'' subset_bs' have "bs ⊆ bs''" by auto
with subrobdds_set_mono2 [of bs bs'']
have "subrobdds_set bs ⊆ subrobdds_set bs''" by simp
with subrobdds_set_mono[of bs]
have "bs ⊆ subrobdds_set bs''" by simp
thus "subrobdds b' ∪ bs ⊆ subrobdds_set bs'''"
unfolding bs'''_def
by (simp add: subset_iff)
next
from b'_invar
show "robdd_invar_ext (subrobdds_set bs''') n b'"
unfolding robdd_invar_ext_def robdd_invar_ids_def
using robdd_invar_vars_greater___weaken[of v'' b' n]
v''_eq min_var_b12_ge_n by simp
next
show "∀a. robdd_α b' a = bop (robdd_α b1 a) (robdd_α b2 a)" by fact
next
from invar_rev_map''' subrobdds_set_mono[of bs''']
show "rev_map_invar (subrobdds_set bs''') rev_map'''"
unfolding rev_map_invar_def by (simp add: subset_iff)
next
from robdd_id_map_properties[of bs1] invar_ids_equal_bs1 b1_in
have id_map_b1: "robdd_id_map bs1 (robdd_get_id b1) = Some b1"
by (simp add: robdd_id_map_OK_def)
from robdd_id_map_properties[of bs2] invar_ids_equal_bs2 b2_in
have id_map_b2: "robdd_id_map bs2 (robdd_get_id b2) = Some b2"
by (simp add: robdd_id_map_OK_def)
{ fix n b
assume b_invar: "robdd_invar_ext bs'' n b"
from b'_invar have ids_bs''': "robdd_invar_ids bs'''" unfolding robdd_invar_ext_def by simp
from b_invar subrobdds_set_mono2 [of bs'' bs'''] ids_bs'''
have "robdd_invar_ext bs''' n b"
unfolding robdd_invar_ext_def bs'''_def by simp
} note invar_bs'''_ext = this
from invar_apply_map'' b'_invar
show "apply_map_invar bop (subrobdds_set bs''') bs1 bs2 apply_map'''"
unfolding apply_map'''_def apply_map_invar_def
apply (elim conjE)
apply (simp add: c.lookup_correct c.update_correct id_map_b1 id_map_b2 v''_eq sem_OK)
apply (metis invar_bs'''_ext)
done
qed
thus ?thesis by blast
qed
qed
qed
lemma robdd_apply_correct :
fixes b1 b2 bop rev_map apply_map
defines "res ≡ robdd_apply (c_empty ()) (r_empty (), 2) bop b1 b2"
defines "b ≡ fst res"
assumes b1_invar: "robdd_invar b1"
and b2_invar: "robdd_invar b2"
shows "robdd_invar b ∧ (∀a. robdd_α b a ⟷ bop (robdd_α b1 a) (robdd_α b2 a))"
proof -
from robdd_apply_correct_full [OF rev_map_invar_empty apply_map_invar_empty
b1_invar[unfolded robdd_invar_def] b2_invar[unfolded robdd_invar_def], of bop,
folded res_def b_def] b1_invar b2_invar
obtain bs where invar_ext: "robdd_invar_ext bs 0 b"
and sem_OK: "∀a. robdd_α b a = bop (robdd_α b1 a) (robdd_α b2 a)" by auto
from invar_ext have invar: "robdd_invar b"
by (rule robdd_invar_impl)
from invar sem_OK show ?thesis by simp
qed
definition robdd_neg where
"robdd_neg apply_map rev_map b = robdd_apply apply_map rev_map (λb1 b2. ¬(b1 ∧ b2)) b robdd_one"
lemma robdd_neg_correct_full :
fixes b rev_map apply_map bs
defines "res ≡ robdd_neg apply_map rev_map b"
defines "b' ≡ fst res"
defines "apply_map' ≡ fst (snd res)"
defines "rev_map' ≡ snd (snd res)"
assumes invar_rev_map: "rev_map_invar bs rev_map"
and invar_apply_map: "apply_map_invar (λb1 b2. ¬(b1 ∧ b2)) bs bs1 bs2 apply_map"
and b_invar: "robdd_invar_ext bs1 n b"
and bs1_OK: "⋀b. b ∈ bs1 ⟹ robdd_invar b"
and bs2_OK: "⋀b. b ∈ bs2 ⟹ robdd_invar b" "robdd_invar_ids bs2"
shows "∃bs'.
subrobdds b' ∪ bs ⊆ bs' ∧
robdd_invar_ext bs' n b' ∧
apply_map_invar (λb1 b2. ¬(b1 ∧ b2)) bs' bs1
(insert robdd_zero (insert robdd_one bs2)) apply_map' ∧
rev_map_invar bs' rev_map' ∧
(∀a. robdd_α b' a ⟷ ¬ (robdd_α b a))"
proof -
from bs2_OK have "robdd_invar_ids_leafs bs2"
apply (rule_tac robdd_invar_ids_leafs_intro)
apply (simp_all add: robdd_invar_def robdd_invar_ext_def)
done
with bs2_OK(2) have "robdd_invar_ids_full bs2" by (simp add: robdd_invar_ids_full_def)
hence bs2'_invar: "robdd_invar_ids (insert robdd_zero (insert robdd_one bs2))"
unfolding robdd_invar_ids_full_alt_def by simp
from b_invar
have bs1_invar: "robdd_invar_ids bs1"
unfolding robdd_invar_ext_def by simp
from invar_apply_map have
invar_apply_map': "apply_map_invar (λb1 b2. ¬(b1 ∧ b2)) bs bs1
(insert robdd_zero (insert robdd_one bs2)) apply_map"
apply (rule apply_map_invar_extend)
apply (auto simp add: subset_iff bs1_OK bs2_OK bs2'_invar bs1_invar)
done
from robdd_apply_correct_full[OF invar_rev_map invar_apply_map' b_invar _ bs1_OK, of robdd_one]
res_def[symmetric]
show ?thesis apply (simp add: robdd_neg_def b'_def[symmetric] apply_map'_def[symmetric]
rev_map'_def[symmetric])
by (metis bs2_OK(1) bs2'_invar robdd_invar_simps_leafs)
qed
lemma robdd_neg_correct :
fixes b rev_map apply_map bs
defines "res ≡ robdd_neg (c_empty ()) (r_empty (), 2) b"
defines "bn ≡ fst res"
assumes b_invar: "robdd_invar b"
shows "robdd_invar bn ∧ (∀a. robdd_α bn a ⟷ ¬(robdd_α b a))"
unfolding res_def bn_def robdd_neg_def
using robdd_apply_correct [OF b_invar, of robdd_one "(λb1 b2. ¬(b1 ∧ b2))"]
by simp
lemma robdd_neg_alt_def :
"robdd_neg apply_map rev_map b =
(case (bope_neg (robdd_to_bool b)) of
Some f ⇒ (robdd_leaf f, apply_map, rev_map)
| None ⇒ (case c_lookup (robdd_get_id b, 1) apply_map of
Some b3 ⇒ (b3, apply_map, rev_map)
| None ⇒ (let (l1, r1, var) = robdd_neg_next b in
let (l, apply_map, rev_map) = robdd_neg apply_map rev_map l1 in
let (r, apply_map, rev_map) = robdd_neg apply_map rev_map r1 in
let (b3, rev_map) = robdd_construct rev_map l var r in
let apply_map = c_update (robdd_get_id b, 1) b3 apply_map in
(b3, apply_map, rev_map))))"
proof -
have bope_neg_intro:
"(bool_op_extend (λb1 b2. b1 ⟶ ¬ b2) (robdd_to_bool b) (Some True)) =
(bope_neg (robdd_to_bool b))"
apply (cases "robdd_to_bool b" rule: bool_opt_exhaust)
apply (simp_all)
done
obtain b1_l b1_r v'' b2_l b2_r where
next_eq: "robdd_apply_next b robdd_one = (b1_l, b1_r, v'', b2_l, b2_r)" by (metis prod.exhaust)
from next_eq have b2_eq[simp]: "b2_l = robdd_one" "b2_r = robdd_one"
by (case_tac[!] b) auto
show ?thesis
unfolding robdd_neg_def robdd_apply.simps[of _ _ _ b]
by (simp split: option.splits add: bope_neg_intro next_eq split_def robdd_neg_next_def)
qed
text ‹An auxiliary construct to get the ids of a ROBDD consistent with some cache or
other ROBDDs.›
definition robdd_copy where
"robdd_copy apply_map rev_map b = robdd_apply apply_map rev_map (λb1 b2. (b1 ∧ b2)) b robdd_one"
lemma robdd_copy_correct_full :
fixes b rev_map apply_map bs
defines "res ≡ robdd_copy apply_map rev_map b"
defines "b' ≡ fst res"
defines "apply_map' ≡ fst (snd res)"
defines "rev_map' ≡ snd (snd res)"
assumes invar_rev_map: "rev_map_invar bs rev_map"
and invar_apply_map: "apply_map_invar (λb1 b2. (b1 ∧ b2)) bs bs1 bs2 apply_map"
and b_invar: "robdd_invar_ext bs1 n b"
and bs1_OK: "⋀b. b ∈ bs1 ⟹ robdd_invar b"
and bs2_OK: "⋀b. b ∈ bs2 ⟹ robdd_invar b" "robdd_invar_ids bs2"
shows "∃bs'.
subrobdds b' ∪ bs ⊆ bs' ∧
robdd_invar_ext bs' n b' ∧
apply_map_invar (λb1 b2. (b1 ∧ b2)) bs' bs1
(insert robdd_zero (insert robdd_one bs2)) apply_map' ∧
rev_map_invar bs' rev_map' ∧
(∀a. robdd_α b' a ⟷ (robdd_α b a))"
proof -
from bs2_OK have "robdd_invar_ids_leafs bs2"
apply (rule_tac robdd_invar_ids_leafs_intro)
apply (simp_all add: robdd_invar_def robdd_invar_ext_def)
done
with bs2_OK(2) have "robdd_invar_ids_full bs2" by (simp add: robdd_invar_ids_full_def)
hence bs2'_invar: "robdd_invar_ids (insert robdd_zero (insert robdd_one bs2))"
unfolding robdd_invar_ids_full_alt_def by simp
from b_invar
have bs1_invar: "robdd_invar_ids bs1"
unfolding robdd_invar_ext_def by simp
from invar_apply_map have
invar_apply_map': "apply_map_invar (λb1 b2. (b1 ∧ b2)) bs bs1
(insert robdd_zero (insert robdd_one bs2)) apply_map"
apply (rule apply_map_invar_extend)
apply (auto simp add: subset_iff bs1_OK bs2_OK bs2'_invar bs1_invar)
done
from robdd_apply_correct_full[OF invar_rev_map invar_apply_map' b_invar _ bs1_OK, of robdd_one]
res_def[symmetric]
show ?thesis apply (simp add: robdd_copy_def b'_def[symmetric] apply_map'_def[symmetric]
rev_map'_def[symmetric])
by (metis bs2_OK(1) bs2'_invar robdd_invar_simps_leafs)
qed
lemma robdd_copy_correct :
fixes b rev_map apply_map bs
defines "res ≡ robdd_copy (c_empty ()) rev_map b"
defines "b' ≡ fst res"
defines "rev_map' ≡ snd (snd res)"
assumes invar_rev_map: "rev_map_invar bs rev_map"
and b_invar: "robdd_invar_ext {b} n b"
shows "∃bs'.
subrobdds b' ∪ bs ⊆ bs' ∧
robdd_invar_ext bs' n b' ∧
rev_map_invar bs' rev_map' ∧
(∀a. robdd_α b' a ⟷ (robdd_α b a))"
using res_def[symmetric]
using robdd_copy_correct_full [OF invar_rev_map _ b_invar, of "{}" "c_empty ()"]
apply (simp add: apply_map_invar_def c.empty_correct c.lookup_correct robdd_invar_ids_def
b'_def[symmetric] rev_map'_def[symmetric])
apply (metis b_invar robdd_invar_impl)
done
lemma robdd_copy_alt_def :
"robdd_copy apply_map rev_map b =
(case (robdd_to_bool b) of
Some f ⇒ (robdd_leaf f, apply_map, rev_map)
| None ⇒ (case c_lookup (robdd_get_id b, 1) apply_map of
Some b3 ⇒ (b3, apply_map, rev_map)
| None ⇒ (let (l1, r1, var) = robdd_neg_next b in
let (l, apply_map, rev_map) = robdd_copy apply_map rev_map l1 in
let (r, apply_map, rev_map) = robdd_copy apply_map rev_map r1 in
let (b3, rev_map) = robdd_construct rev_map l var r in
let apply_map = c_update (robdd_get_id b, 1) b3 apply_map in
(b3, apply_map, rev_map))))"
proof -
have bope_neg_intro:
"(bool_op_extend (λb1 b2. b1 ∧ b2) (robdd_to_bool b) (Some True)) =
(robdd_to_bool b)"
apply (cases "robdd_to_bool b" rule: bool_opt_exhaust)
apply (simp_all)
done
obtain b1_l b1_r v'' b2_l b2_r where
next_eq: "robdd_apply_next b robdd_one = (b1_l, b1_r, v'', b2_l, b2_r)" by (metis prod.exhaust)
from next_eq have b2_eq[simp]: "b2_l = robdd_one" "b2_r = robdd_one"
by (case_tac[!] b) auto
show ?thesis
unfolding robdd_copy_def robdd_apply.simps[of _ _ _ b]
by (simp split: option.splits add: bope_neg_intro next_eq split_def robdd_neg_next_def)
qed
definition restrict_map_invar where
"restrict_map_invar f bs res_map ⟷
c_invar res_map ∧
(∀i v b. c_lookup (v, i) res_map = Some b ⟶
(∃b'. robdd_id_map bs i = Some b' ∧ b ∈ bs ∧
robdd_invar_ext bs (robdd_get_var b') b ∧
(∀a. robdd_α b a ⟷ robdd_α b' (a(v := f)))))"
lemma restrict_map_invar_empty :
"restrict_map_invar f bs (c_empty ())"
unfolding restrict_map_invar_def by (simp add: c.empty_correct c.lookup_correct)
lemma restrict_map_invar_I :
"⟦c_invar res_map;
⋀i v b. c_lookup (v, i) res_map = Some b ⟹
(∃b'. robdd_id_map bs i = Some b' ∧ b ∈ bs ∧
robdd_invar_ext bs (robdd_get_var b') b ∧
(∀a. robdd_α b a ⟷ robdd_α b' (a(v := f))))⟧ ⟹
restrict_map_invar f bs res_map"
unfolding restrict_map_invar_def by blast
lemma restrict_map_invar_D1 :
"restrict_map_invar f bs res_map ⟹ c_invar res_map"
unfolding restrict_map_invar_def by blast
lemma restrict_map_invar_D2 :
"⟦restrict_map_invar f bs res_map;
c_lookup (v, i) res_map = Some b⟧ ⟹
(∃b'. robdd_id_map bs i = Some b' ∧ b ∈ bs ∧
robdd_invar_ext bs (robdd_get_var b') b ∧
(∀a. robdd_α b a ⟷ robdd_α b' (a(v := f))))"
unfolding restrict_map_invar_def by blast
fun robdd_restrict where
"robdd_restrict res_map rev_map f rv b =
(case b of (robdd_leaf f') ⇒ (robdd_leaf f', res_map, rev_map)
| (robdd_var i l v r) ⇒
(if (rv < v) then (b, res_map, rev_map) else (
if (rv = v) then (if f then l else r, res_map, rev_map) else (
(case c_lookup (rv, i) res_map of
Some b3 ⇒ (b3, res_map, rev_map)
| None ⇒ (let (l', res_map, rev_map) = robdd_restrict res_map rev_map f rv l in
let (r', res_map, rev_map) = robdd_restrict res_map rev_map f rv r in
let (b3, rev_map) = robdd_construct rev_map l' v r' in
let res_map = c_update (rv, i) b3 res_map in
(b3, res_map, rev_map))
)))))"
declare robdd_restrict.simps [simp del]
lemma robdd_restrict_correct_full :
fixes b f rv rev_map res_map bs
defines "res ≡ robdd_restrict res_map rev_map f rv b"
defines "b' ≡ fst res"
defines "res_map' ≡ fst (snd res)"
defines "rev_map' ≡ snd (snd res)"
assumes invar_rev_map: "rev_map_invar bs rev_map"
and invar_res_map: "restrict_map_invar f bs res_map"
and b_invar: "robdd_invar_ext bs n b"
and b_sub: "subrobdds b ⊆ bs"
shows "∃bs'. insert b' bs ⊆ bs' ∧
robdd_invar_ext bs' n b' ∧
restrict_map_invar f bs' res_map' ∧
rev_map_invar bs' rev_map' ∧
(∀a. robdd_α b' a ⟷ (robdd_α b (a(rv := f))))"
using invar_rev_map invar_res_map b_invar b_sub
unfolding b'_def res_map'_def rev_map'_def res_def
proof (induct b arbitrary: bs n res_map rev_map)
case (robdd_leaf f')
thus ?case by (rule_tac exI [where x = bs]) (simp add: robdd_restrict.simps)
next
case (robdd_var i l v r)
note indhyp_l = robdd_var(1)
note indhyp_r = robdd_var(2)
note invar_rev_map = robdd_var(3)
note invar_res_map = robdd_var(4)
note b_invar = robdd_var(5)
note b_sub = robdd_var(6)
let ?b = "robdd_var i l v r"
let ?res = "robdd_restrict res_map rev_map f rv ?b"
from b_invar have b_in_bs: "?b ∈ subrobdds_set bs" unfolding robdd_invar_ext_def by simp
from rev_map_invar_implies_invar_ids[OF invar_rev_map]
have invar_ids_bs: "robdd_invar_ids bs" by simp
note bs_OK_full = rev_map_invar_implies_invar_bs[OF invar_rev_map]
have bs_OK: "⋀b. b ∈ bs ⟹ robdd_invar b" by (metis bs_OK_full subrobdds_set_mono subsetD)
have invar_ids_equal_bs: "robdd_invar_ids_equal bs"
by (rule robdd_invar_ids_equal_intro [OF bs_OK invar_ids_bs])
have invar_ids_leafs_bs : "robdd_invar_ids_leafs bs"
proof (rule robdd_invar_ids_leafs_intro[of bs, OF _ invar_ids_bs])
fix b
assume "b ∈ bs"
with bs_OK[of b] have "robdd_invar b" by simp
thus "robdd_invar_reduced b" unfolding robdd_invar_def robdd_invar_ext_def by simp
qed
from b_invar have invars_greater: "robdd_invar_vars_greater (Suc v) l" "robdd_invar_vars_greater (Suc v) r"
by (simp_all add: robdd_invar_ext_def)
show ?case
proof (cases "rv < v")
case True note rv_less = this
have sem_simp :
"⋀a bb. robdd_invar_vars_greater (Suc v) bb ⟹
robdd_α bb (λx. (x = rv ⟶ f) ∧ (x ≠ rv ⟶ a x)) = robdd_α bb a"
apply (rule_tac robdd_α_invar_greater[of "Suc v"])
apply (insert rv_less)
apply (simp_all)
done
show ?thesis using rv_less b_invar b_sub
apply (rule_tac exI[where x = bs])
apply (simp add: invar_rev_map invar_res_map robdd_restrict.simps)
apply (simp add: invars_greater sem_simp)
done
next
case False hence v_le: "v ≤ rv" by simp
show ?thesis
proof (cases "rv = v")
case True note rv_eq [simp] = this
from invars_greater(2) have r_simp :
"⋀a. robdd_α r (λx. x ≠ v ∧ a x) = robdd_α r a"
apply (rule_tac robdd_α_invar_greater[of "Suc v"])
apply (simp_all)
done
from invars_greater(1) have l_simp :
"⋀a. robdd_α l (λx. (x ≠ v ⟶ a x)) = robdd_α l a"
apply (rule_tac robdd_α_invar_greater[of "Suc v"])
apply (simp_all)
done
from b_invar robdd_invar_ext_weaken_var[of bs "Suc v" _ n]
have "robdd_invar_ext bs n l" "robdd_invar_ext bs n r" by simp_all
thus ?thesis using b_invar b_sub
supply map_upd_eq_restrict[simp]
apply (rule_tac exI[where x = bs])
apply (simp add: invar_rev_map invar_res_map robdd_restrict.simps)
apply (simp add: l_simp r_simp subset_iff)
done
next
case False with v_le have v_less: "v < rv" by simp
show ?thesis
proof (cases "c_lookup (rv, i) res_map")
case (Some b3) note lookup_eq = this
from robdd_id_map_properties[of bs] invar_ids_equal_bs
have "robdd_id_map_OK bs (robdd_id_map bs)" by simp
with robdd_id_map_OK_D[of bs "robdd_id_map bs", OF _ b_in_bs]
have "robdd_id_map bs i = Some ?b" by simp
with restrict_map_invar_D2[OF invar_res_map lookup_eq] v_less
have invar_b3: "robdd_invar_ext bs v b3" and
b3_in_bs: "b3 ∈ bs" and
sem_b3: "∀a. robdd_α b3 a = (if a v then robdd_α l (a(rv := f)) else
robdd_α r (a(rv := f)))" by simp_all
from invar_b3 b_invar have invar_b3': "robdd_invar_ext bs n b3"
apply (rule_tac robdd_invar_ext_weaken_var[of _ v])
apply simp_all
done
have "⋀a. (λx. (x = rv ⟶ f) ∧ (x ≠ rv ⟶ a x)) = a (rv := f)"
by (simp add: fun_eq_iff)
with lookup_eq
show ?thesis using v_less b3_in_bs
apply (rule_tac exI[where x = bs])
apply (simp add: sem_b3 invar_b3' invar_rev_map invar_res_map robdd_restrict.simps)
done
next
case None note lookup_eq = this
obtain l' res_map' rev_map' where
res_l_eq: "robdd_restrict res_map rev_map f rv l = (l', res_map', rev_map')"
by (metis prod.exhaust)
obtain r' res_map'' rev_map'' where
res_r_eq: "robdd_restrict res_map' rev_map' f rv r = (r', res_map'', rev_map'')"
by (metis prod.exhaust)
obtain b3 rev_map''' where
const_eq: "robdd_construct rev_map'' l' v r' = (b3, rev_map''')"
by (metis prod.exhaust)
from b_invar b_sub indhyp_l [OF invar_rev_map invar_res_map, of "Suc v"]
obtain bs' where
subset_bs': "insert l' bs ⊆ bs'" and
l'_invar: "robdd_invar_ext bs' (Suc v) l'" and
invar_res_map': "restrict_map_invar f bs' res_map'" and
invar_rev_map': "rev_map_invar bs' rev_map'" and
sem_l': "∀a. robdd_α l' a = (robdd_α l (λb. if b = rv then f else a b))"
by (simp add: invar_rev_map invar_res_map res_l_eq) blast
from b_invar have "robdd_invar_ext bs (Suc v) r" by simp
with l'_invar subset_bs' have "robdd_invar_ext bs' (Suc v) r"
unfolding robdd_invar_ext_def by simp (metis subrobdds_set_mono2 subsetD)
with b_sub subset_bs' indhyp_r [OF invar_rev_map' invar_res_map', of "Suc v"]
obtain bs'' where
subset_bs'': "insert r' bs' ⊆ bs''" and
r'_invar: "robdd_invar_ext bs'' (Suc v) r'" and
invar_res_map'': "restrict_map_invar f bs'' res_map''" and
invar_rev_map'': "rev_map_invar bs'' rev_map''" and
sem_r': "∀a. robdd_α r' a = (robdd_α r (λb. if b = rv then f else a b))"
by (simp add: subset_iff invar_rev_map invar_res_map res_r_eq) blast
from l'_invar r'_invar subset_bs' subset_bs''
have l'_invar': "robdd_invar_ext bs'' (Suc v) l'"
unfolding robdd_invar_ext_def by simp (metis subrobdds_set_mono2 subsetD)
from subset_bs' subset_bs'' have "l' ∈ bs''" "r' ∈ bs''"
by (simp_all add: subset_iff)
from robdd_construct_correct [OF invar_rev_map'' ‹l' ∈ bs''› ‹r' ∈ bs''›
l'_invar' r'_invar]
have b3_invar: "robdd_invar_ext (insert b3 bs'') v b3" and
invar_rev_map''': "rev_map_invar (insert b3 bs'') rev_map'''" and
sem_b3: "robdd_α b3 = robdd_α (robdd_var 0 l' v r')"
by (simp_all add: const_eq)
from b3_invar b_invar have b3_invar': "robdd_invar_ext (insert b3 bs'') n b3"
apply (rule_tac robdd_invar_ext_weaken_var[of _ v])
apply simp_all
done
from subset_bs' subset_bs'' have bs_sub: "bs ⊆ insert b3 bs''"
by (simp add: subset_iff)
have invar_res_map''':
"restrict_map_invar f (insert b3 bs'') (c_update (rv, i) b3 res_map'')"
proof -
from b_in_bs subset_bs' subset_bs''
have b_in': "robdd_var i l v r ∈ subrobdds_set bs''"
unfolding subrobdds_set_def by (simp add: subset_iff Bex_def) blast
from robdd_id_map_union [of "{b3}" bs'']
rev_map_invar_implies_invar_ids_equal[OF invar_rev_map''']
have id_map_eq: "robdd_id_map (insert b3 bs'') = robdd_id_map {b3} ++ robdd_id_map bs''" by simp
from robdd_id_map_properties[of "insert b3 bs''"] b_in'
rev_map_invar_implies_invar_ids_equal[OF invar_rev_map''']
robdd_id_map_OK_D [of "insert b3 bs''" "robdd_id_map (insert b3 bs'')" ?b]
have map_id_i: "robdd_id_map (insert b3 bs'') i = Some ?b" by simp
note c_invar = restrict_map_invar_D1[OF invar_res_map'']
show ?thesis
proof (rule restrict_map_invar_I, goal_cases)
from restrict_map_invar_D1[OF invar_res_map'']
show "c_invar (c_update (rv, i) b3 res_map'')" by (simp add: c.update_correct)
next
case prems: (2 i' v' b')
note lookup_eq = prems(1)
show ?case
proof (cases "i' = i ∧ v' = rv")
case True note iv'_eq = this
with lookup_eq map_id_i sem_b3 b3_invar v_less show ?thesis
by (simp add: c_invar c.update_correct c.lookup_correct
sem_l' sem_r' fun_upd_def)
next
case False
with lookup_eq have lookup_eq': "c_lookup (v', i') res_map'' = Some b'"
by (auto simp add: c_invar c.lookup_correct c.update_correct)
from restrict_map_invar_D2[OF invar_res_map'' lookup_eq']
obtain b'' where b''_props:
"robdd_id_map bs'' i' = Some b''" "b' ∈ bs''"
"robdd_invar_ext bs'' (robdd_get_var b'') b'"
"∀a. robdd_α b' a = robdd_α b'' (a(v' := f))" by auto
show ?thesis
apply (rule_tac exI[where x = b''])
apply (simp add: id_map_eq map_add_Some_iff b''_props)
apply (insert b3_invar b''_props(3))
apply (simp add: robdd_invar_ext_def)
done
qed
qed
qed
from robdd_restrict.simps[of res_map rev_map f rv ?b]
show ?thesis using v_less
apply (rule_tac exI[where x = "insert b3 bs''"])
apply (simp add: lookup_eq res_l_eq res_r_eq const_eq invar_rev_map'''
sem_b3 sem_l' sem_r' b3_invar' bs_sub invar_res_map''')
done
qed
qed
qed
qed
end
subsection ‹Semantics on lists›
text ‹BDDs represent boolean expression. I.e. they are functions from assignments to
\texttt{True} or \texttt{False}. Here, assignments are represented by functions from
variable indices to the values of these Boolean variables. While this reprentation of
is convenient for proofs, a representation based on lists is more convinient for execution.›
definition list_to_assignment_set :: "bool option list ⇒ (nat ⇒ bool) set" where
"list_to_assignment_set l = {a . (∀v < length l. (∀f. l ! v = Some f ⟶ a v = f))}"
definition shift_assignment where
"shift_assignment (b::bool) a = (λv. case v of 0 ⇒ b | Suc v' ⇒ a v')"
lemma inj_shift_assignement :
"inj_on (shift_assignment b) S"
unfolding inj_on_def shift_assignment_def
by (simp add: fun_eq_iff split: nat.splits)
lemma list_to_assignment_set_None_simp [simp] :
"list_to_assignment_set (None # l) =
list_to_assignment_set (Some True # l) ∪ list_to_assignment_set (Some False # l)"
unfolding list_to_assignment_set_def
apply (simp add: set_eq_iff less_Suc_eq_0_disj
del: all_simps add: all_simps[symmetric])
apply (simp add: all_conj_distrib)
apply (intro allI iffI)
apply simp
apply (elim disjE conjE)
apply simp_all
done
lemma list_to_assignment_set_simps [simp]:
"list_to_assignment_set [] = UNIV" (is ?T1)
"list_to_assignment_set (Some b # l) = (shift_assignment b) ` (list_to_assignment_set l)" (is "?T3 b")
proof -
show ?T1 unfolding list_to_assignment_set_def by simp
next
show "?T3 b"
unfolding list_to_assignment_set_def
apply (simp add: set_eq_iff less_Suc_eq_0_disj shift_assignment_def
del: all_simps add: all_simps[symmetric])
apply (simp add: all_conj_distrib image_iff)
apply (intro allI iffI)
apply (rule_tac x = "λv. x (Suc v)" in exI)
apply (simp add: fun_eq_iff split: nat.split)
apply auto
done
qed
lemma infinite_list_to_assignment_set :
"¬(finite (list_to_assignment_set l))"
proof (induct l)
case Nil note l_eq = this
have inf_UNIV: "¬(finite (UNIV :: (nat ⇒ bool) set))"
proof (rule notI)
assume fin_UNIV: "finite (UNIV :: (nat ⇒ bool) set)"
from finite_fun_UNIVD1[OF fin_UNIV]
show False by simp
qed
thus ?case by simp
next
case (Cons bo l')
note ind_hyp = Cons
obtain b where sub_b: "list_to_assignment_set (Some b # l') ⊆ list_to_assignment_set (bo # l')"
by (cases bo) auto
have not_fin_b: "¬(finite (list_to_assignment_set (Some b # l')))"
proof (rule notI)
assume "finite (list_to_assignment_set (Some b # l'))"
hence "finite (list_to_assignment_set l')"
apply (simp) apply (rule finite_imageD [of "shift_assignment b"])
apply (simp_all add: inj_shift_assignement)
done
with ind_hyp show False by simp
qed
from finite_subset[OF sub_b] not_fin_b
show ?case by blast
qed
lemma list_to_assignment_set_not_empty :
"(list_to_assignment_set l) ≠ {}"
by (metis finite.emptyI infinite_list_to_assignment_set)
fun robdd_list_α where
"robdd_list_α (robdd_leaf f) n l = f"
| "robdd_list_α (robdd_var i l v r) n [] = False"
| "robdd_list_α (robdd_var i l v r) n (bo # bs) =
(if n = v then
(case bo of None ⇒ robdd_list_α l (Suc n) bs ∧ robdd_list_α r (Suc n) bs
| Some True ⇒ robdd_list_α l (Suc n) bs
| Some False ⇒ robdd_list_α r (Suc n) bs)
else (robdd_list_α (robdd_var i l v r) (Suc n) bs))"
lemma robdd_list_α_correct_aux :
assumes invar: "robdd_invar_vars_greater n b" "robdd_invar_reduced b"
shows "robdd_list_α b n l ⟷ (∀a ∈ (list_to_assignment_set l). robdd_α b (λv. a (v - n)))"
using invar
proof (induct b n l rule: robdd_list_α.induct)
case (1 f n l)
with list_to_assignment_set_not_empty[of l] show ?case by auto
next
case prems: (2 i ll v rr n)
note invar = prems(1,2)
from invar have "robdd_α ll ≠ robdd_α rr"
by (metis robdd_equiv_alt_def_full robdd_invar_reduced.simps(2)
robdd_invar_vars_greater.simps(2) robdd_invar_vars_impl)
then obtain a where a_sem_neq: "robdd_α ll a ≠ robdd_α rr a" by (auto simp add: fun_eq_iff)
define aa where "aa v = a (v + n)" for v
from invar(1) have ll_sem: "⋀b. robdd_α ll (λv'. (aa(v - n := b)) (v' - n)) = robdd_α ll a"
apply (rule_tac robdd_α_invar_greater [of "Suc v"])
apply (simp_all add: aa_def)
apply auto
done
from invar(1) have rr_sem: "⋀b. robdd_α rr (λv'. (aa(v - n := b)) (v' - n)) = robdd_α rr a"
apply (rule_tac robdd_α_invar_greater [of "Suc v"])
apply (simp_all add: aa_def)
apply auto
done
show ?case
proof (cases "robdd_α ll a")
case True with a_sem_neq rr_sem show ?thesis
apply (simp)
apply (rule_tac exI[where x = "aa(v-n := False)"])
apply simp
done
next
case False with a_sem_neq ll_sem show ?thesis
apply (simp)
apply (rule_tac exI[where x = "aa(v-n := True)"])
apply simp
done
qed
next
case prems: (3 i ll v rr n b bs)
note invar = prems(6,7)
hence invar_rr: "robdd_invar_vars_greater (Suc n) rr" and red_ll: "robdd_invar_reduced ll"
and invar_ll: "robdd_invar_vars_greater (Suc n) ll" and red_rr: "robdd_invar_reduced rr"
and invar_n: "n ≠ v ⟹ robdd_invar_vars_greater (Suc n) (robdd_var i ll v rr)"
and n_le: "n ≤ v"
using robdd_invar_vars_greater___weaken [of "Suc v" _ "Suc n"] by simp_all
note indhyp_1 = prems(1)[OF _ _ invar_ll red_ll]
note indhyp_2 = prems(2)[OF _ _ invar_rr red_rr]
note indhyp_3 = prems(3)[of True, OF _ _ _ invar_ll red_ll, simplified]
note indhyp_4 = prems(4)[of False, OF _ _ _ invar_rr red_rr, simplified]
note indhyp_5 = prems(5)[OF _ invar_n invar(2), simplified]
from invar_ll have ll_sem: "⋀a b. robdd_α ll (λv. case_nat b a (v - n)) = robdd_α ll
(λv. a (v - Suc n))"
apply (rule_tac robdd_α_invar_greater [of "Suc n"])
apply (simp_all split: nat.splits)
apply (metis diff_Suc nat.case(2))
done
from invar_rr have rr_sem: "⋀a b. robdd_α rr (λv. case_nat b a (v - n)) = robdd_α rr
(λv. a (v - Suc n))"
apply (rule_tac robdd_α_invar_greater [of "Suc n"])
apply (simp_all split: nat.splits)
apply (metis diff_Suc nat.case(2))
done
show ?case
proof (cases "n = v")
case False with n_le have n_less: "n < v" by simp
hence "v - n = Suc (v - (Suc n))" by simp
with indhyp_5 n_less
show ?thesis
apply (simp add: Ball_def all_conj_distrib del: Suc_diff)
apply (cases b)
apply (simp_all add: image_iff Bex_def ex_disj_distrib all_conj_distrib imp_conjR
shift_assignment_def imp_ex all_simps(6)[symmetric]
ll_sem rr_sem split: nat.split
del: ex_simps all_simps Suc_diff)
done
next
case True note n_eq[simp] = this
from indhyp_1 indhyp_2 indhyp_3 indhyp_4
show ?thesis apply (simp add: Ball_def split: option.splits bool.splits)
apply (simp_all add: image_iff Bex_def ex_disj_distrib all_conj_distrib imp_conjR
shift_assignment_def imp_ex all_simps(6)[symmetric]
ll_sem[unfolded n_eq] rr_sem[unfolded n_eq]
del: ex_simps all_simps)
done
qed
qed
lemma robdd_list_α_correct:
assumes b_OK: "robdd_invar_vars b" "robdd_invar_reduced b"
shows "robdd_list_α b 0 l ⟷ (∀a ∈ (list_to_assignment_set l). robdd_α b a)"
using robdd_list_α_correct_aux [of 0 b] b_OK unfolding robdd_invar_vars_def by simp
fun robdd_iteratei where
"robdd_iteratei n ac (robdd_leaf f) = (if f then set_iterator_sng ac else set_iterator_emp)" |
"robdd_iteratei n ac (robdd_var i l v r) =
(set_iterator_union (robdd_iteratei (Suc v) ((Some True) # ((replicate (v-n) None) @ ac)) l)
(robdd_iteratei (Suc v) ((Some False) # ((replicate (v-n) None) @ ac)) r))"
end
Theory Locale_Code_Ex
section ‹Example for locale-code›
theory Locale_Code_Ex
imports
Locale_Code
"../../Lib/Code_Target_ICF"
begin
definition [simp, code del]: "NOCODE ≡ id"
locale test =
fixes a b :: nat
assumes "a=b"
begin
text ‹Mutually recursive functions›
fun g and f where
"g 0 = NOCODE a"
| "g (Suc n) = a + n + f n"
| "f 0 = a+b"
| "f (Suc n) = a + f n + b * f n + g n"
text ‹Various definitions, depending on more or less parameters›
definition "k x ≡ b + x :: nat"
definition "j x y ≡ NOCODE x + y + f x :: nat"
definition "i x y ≡ x + y :: nat"
definition "h x y ≡ a+x+k y+i x y+j x y"
lemmas "defs" = k_def j_def i_def h_def g.simps f.simps
lemma j_alt: "j x y ≡ f x + y + x" unfolding j_def by (simp add: ac_simps)
lemma g_alt:
"g 0 = a"
"g (Suc n) = f n + n + a"
by (auto simp: ac_simps)
definition "c ≡ a + b"
local_setup ‹Locale_Code.lc_decl_eq @{thms j_alt}›
local_setup ‹Locale_Code.lc_decl_eq @{thms g_alt}›
end
text ‹Conflicting constant name›
definition "h_zero_zero ≡ True"
setup Locale_Code.open_block
text ‹Various interpretations, with and without constructor patterns
and free variables›
interpretation i0: test 0 0 apply unfold_locales by auto
interpretation i1: test "Suc n" "Suc n" apply unfold_locales by auto
interpretation i2: test 1 1 apply unfold_locales by auto
interpretation i3: test 5 5 apply unfold_locales by auto
interpretation i4: test "snd (x,3)" "1+2" apply unfold_locales by auto
interpretation i5: test "i3.c" "i3.c" by unfold_locales simp
text ‹Setup some alternative equations›
lemma i0_f_pat:
"i0.f 0 = 0"
"i0.f (Suc n) = i0.f n + i0.g n"
by simp_all
lemma i0_h_pat: "i0.h x y = x+i0.k y+i0.i x y+i0.j x y"
unfolding i0.h_def by auto
declare [[ lc_add "i0.f" i0_f_pat and "i0.h" i0_h_pat]]
setup Locale_Code.close_block
definition "foo x y ≡ i0.h x y + i1.h x x y + i2.h x y + i3.h x y
+ i4.h TYPE(bool) h_zero_zero x y + i5.h x y"
definition "bar x y ≡ i0.f x + i1.f x y + i2.f x + i3.f y
+ i4.f TYPE(bool) False x + i5.f y"
code_thms foo
code_thms bar
text ‹value›
value "foo 3 4"
value "bar 3 4"
text ‹eval-tactic›
lemma "foo 3 4 = 34578" by eval
lemma "bar 3 4 = 354189" by eval
text ‹Exported code›
export_code foo bar checking SML
export_code foo bar checking OCaml?
export_code foo bar checking Haskell?
export_code foo bar checking Scala
text ‹Inlined code›
ML_val ‹
@{code foo} (@{code nat_of_integer} 3) (@{code nat_of_integer} 4);
@{code bar} (@{code nat_of_integer} 3) (@{code nat_of_integer} 4);
›
end
Theory DatRef
section ‹\isaheader{Deprecated: Data Refinement for the While-Combinator}›
theory DatRef
imports
Main
"HOL-Library.While_Combinator"
begin
text_raw ‹\label{thy:DatRef}›
text ‹
Note that this theory is deprecated. For new developments, the refinement
framework (Refine-Monadic entry of the AFP) should be used.
›
text ‹
In this theory, a data refinement framework for
non-deterministic while-loops is developed. The refinement is based on
showing simulation w.r.t. an abstraction function.
The case of deterministic while-loops is explicitely handled, to
support proper code-generation using the While-Combinator.
Note that this theory is deprecated. For new developments, the refinement
framework (Refine-Monadic entry of the AFP) should be used.
›
text ‹
A nondeterministic while-algorithm is described by a set of states, a
continuation condition, a step relation, a set of possible initial
states and an invariant.
›
record 'S while_algo =
wa_cond :: "'S set"
wa_step :: "('S × 'S) set"
wa_initial :: "'S set"
wa_invar :: "'S set"
text ‹
A while-algorithm is called {\em well-defined} iff the invariant holds for
all reachable states and the accessible part of the step-relation is
well-founded.
›
locale while_algo =
fixes WA :: "'S while_algo"
assumes step_invar:
"⟦ s∈wa_invar WA; s∈wa_cond WA; (s,s')∈wa_step WA ⟧ ⟹ s'∈wa_invar WA"
assumes initial_invar: "wa_initial WA ⊆ wa_invar WA"
assumes step_wf:
"wf { (s',s). s∈wa_invar WA ∧ s∈wa_cond WA ∧ (s,s')∈wa_step WA }"
text ‹
Next, a refinement relation for while-algorithms is defined.
Note that the involved while-algorithms are not required to
be well-defined. Later, some lemmas to transfer well-definedness
along refinement relations are shown.
Refinement involves a concrete algorithm, an abstract algorithm and an
abstraction function. In essence, a refinement establishes a simulation
of the concrete algorithm by the abstract algorithm w.r.t. the abstraction
function.
›
locale wa_refine =
fixes WAC :: "'C while_algo"
fixes WAA :: "'A while_algo"
fixes α :: "'C ⇒ 'A"
assumes cond_abs: "⟦ s∈wa_invar WAC; s∈wa_cond WAC ⟧ ⟹ α s ∈ wa_cond WAA"
assumes step_abs: "⟦ s∈wa_invar WAC; s∈wa_cond WAC; (s,s')∈wa_step WAC ⟧
⟹ (α s, α s')∈wa_step WAA"
assumes initial_abs: "α ` wa_initial WAC ⊆ wa_initial WAA"
assumes invar_abs: "α ` wa_invar WAC ⊆ wa_invar WAA"
begin
lemma initial_abs': "s∈wa_initial WAC ⟹ α s ∈ wa_initial WAA"
using initial_abs by auto
lemma invar_abs': "s∈wa_invar WAC ⟹ α s ∈ wa_invar WAA"
using invar_abs by auto
end
lemma wa_refine_intro:
fixes condc :: "'C set" and
stepc :: "('C×'C) set" and
initialc :: "'C set" and
invar_addc :: "'C set"
fixes WAA :: "'A while_algo"
fixes α :: "'C ⇒ 'A"
assumes "while_algo WAA"
assumes step_invarc:
"!!s s'. ⟦ s∈invar_addc; s∈condc; α s ∈ wa_invar WAA; (s,s')∈stepc ⟧
⟹ s'∈invar_addc"
assumes initial_invarc: "initialc ⊆ invar_addc"
assumes cond_abs:
"!!s. ⟦ s∈invar_addc; α s ∈ wa_invar WAA; s∈condc ⟧ ⟹ α s ∈ wa_cond WAA"
assumes step_abs:
"!!s s'. ⟦ s∈invar_addc; s∈condc; α s ∈ wa_invar WAA; (s,s')∈stepc ⟧
⟹ (α s, α s')∈wa_step WAA"
assumes initial_abs: "α ` initialc ⊆ wa_initial WAA"
defines "WAC == ⦇
wa_cond=condc,
wa_step=stepc,
wa_initial=initialc,
wa_invar=(invar_addc ∩ {s. α s∈ wa_invar WAA}) ⦈"
shows
"while_algo WAC ∧
wa_refine WAC WAA α" (is "?T1 ∧ ?T2")
proof
interpret waa: while_algo WAA by fact
show G1: "?T1"
apply (unfold_locales)
apply (simp_all add: WAC_def)
apply safe
apply (blast intro!: step_invarc)
apply (frule (3) step_abs)
apply (frule (2) cond_abs)
apply (erule (2) waa.step_invar)
apply (erule rev_subsetD[OF _ initial_invarc])
apply (insert initial_abs waa.initial_invar) [1]
apply blast
apply (rule_tac
r="inv_image { (s',s). s∈wa_invar WAA
∧ s∈wa_cond WAA
∧ (s,s')∈wa_step WAA } α"
in wf_subset)
apply (simp add: waa.step_wf)
apply (auto simp add: cond_abs step_abs) [1]
done
show ?T2
apply (unfold_locales)
apply (auto simp add: cond_abs step_abs initial_abs WAC_def)
done
qed
lemma (in wa_refine) wa_intro:
fixes addi :: "'C set"
assumes "while_algo WAA"
assumes icf: "wa_invar WAC = addi ∩ {s. α s ∈ wa_invar WAA}"
assumes step_addi:
"!!s s'. ⟦ s∈addi; s∈wa_cond WAC; α s ∈ wa_invar WAA;
(s,s')∈wa_step WAC
⟧ ⟹ s'∈addi"
assumes initial_addi: "wa_initial WAC ⊆ addi"
shows
"while_algo WAC"
proof -
interpret waa: while_algo WAA by fact
show ?thesis
apply (unfold_locales)
apply (subst icf)
apply safe
apply (simp only: icf)
apply safe
apply (blast intro!: step_addi)
apply (frule (2) step_abs)
apply (frule (1) cond_abs)
apply (simp only: icf)
apply clarify
apply (erule (2) waa.step_invar)
apply (simp add: icf)
apply (rule conjI)
apply (erule rev_subsetD[OF _ initial_addi])
apply (insert initial_abs waa.initial_invar) [1]
apply blast
apply (rule_tac
r="inv_image { (s',s). s∈wa_invar WAA
∧ s∈wa_cond WAA
∧ (s,s')∈wa_step WAA } α"
in wf_subset)
apply (simp add: waa.step_wf)
apply (auto simp add: cond_abs step_abs icf) [1]
done
qed
text ‹
A special case of refinement occurs, if the concrete condition implements the
abstract condition precisely. In this case, the concrete algorithm will run
as long as the abstract one that it is simulated by. This allows to
transfer properties of the result from the abstract algorithm to the
concrete one.
›
locale wa_precise_refine = wa_refine +
constrains α :: "'C ⇒ 'A"
assumes cond_precise:
"∀s. s∈wa_invar WAC ∧ α s∈wa_cond WAA ⟶ s∈wa_cond WAC"
begin
lemma transfer_correctness:
assumes A: "∀s. s∈wa_invar WAA ∧ s∉wa_cond WAA ⟶ P s"
shows "∀sc. sc∈wa_invar WAC ∧ sc∉wa_cond WAC ⟶ P (α sc)"
using A cond_abs invar_abs cond_precise by blast
end
text ‹Refinement as well as precise refinement is reflexive and transitive›
lemma wa_ref_refl: "wa_refine WA WA id"
by (unfold_locales) auto
lemma wa_pref_refl: "wa_precise_refine WA WA id"
by (unfold_locales) auto
lemma wa_ref_trans:
assumes "wa_refine WC WB α1"
assumes "wa_refine WB WA α2"
shows "wa_refine WC WA (α2∘α1)"
proof -
interpret r1: wa_refine WC WB α1 by fact
interpret r2: wa_refine WB WA α2 by fact
show ?thesis
apply unfold_locales
apply (auto simp add:
r1.invar_abs' r2.invar_abs'
r1.cond_abs r2.cond_abs
r1.step_abs r2.step_abs
r1.initial_abs' r2.initial_abs')
done
qed
lemma wa_pref_trans:
assumes "wa_precise_refine WC WB α1"
assumes "wa_precise_refine WB WA α2"
shows "wa_precise_refine WC WA (α2∘α1)"
proof -
interpret r1: wa_precise_refine WC WB α1 by fact
interpret r2: wa_precise_refine WB WA α2 by fact
show ?thesis
apply intro_locales
apply (rule wa_ref_trans)
apply (unfold_locales)
apply (auto simp add: r1.invar_abs' r2.invar_abs'
r1.cond_precise r2.cond_precise)
done
qed
text ‹
A well-defined while-algorithm is {\em deterministic}, iff
the step relation is a function and there is just one
initial state. Such an algorithm is suitable for direct implementation
by the while-combinator.
For deterministic while-algorithm, an own record is defined, as well as a
function that maps it to the corresponding record for non-deterministic
while algorithms. This makes sense as the step-relation may then be modeled
as a function, and the initial state may be modeled as a single state rather
than a (singleton) set of states.
›
record 'S det_while_algo =
dwa_cond :: "'S ⇒ bool"
dwa_step :: "'S ⇒ 'S"
dwa_initial :: "'S"
dwa_invar :: "'S set"
definition "det_wa_wa DWA == ⦇
wa_cond={s. dwa_cond DWA s},
wa_step={(s,dwa_step DWA s) | s. True},
wa_initial={dwa_initial DWA},
wa_invar = dwa_invar DWA⦈"
locale det_while_algo =
fixes WA :: "'S det_while_algo"
assumes step_invar:
"⟦ s∈dwa_invar WA; dwa_cond WA s ⟧ ⟹ dwa_step WA s ∈ dwa_invar WA"
assumes initial_invar: "dwa_initial WA ∈ dwa_invar WA"
assumes step_wf:
"wf { (dwa_step WA s,s) | s. s∈dwa_invar WA ∧ dwa_cond WA s }"
begin
lemma is_while_algo: "while_algo (det_wa_wa WA)"
apply (unfold_locales)
apply (auto simp add: det_wa_wa_def step_invar initial_invar)
apply (insert step_wf)
apply (erule_tac P=wf in back_subst)
apply auto
done
end
lemma det_while_algo_intro:
assumes "while_algo (det_wa_wa DWA)"
shows "det_while_algo DWA"
proof -
interpret while_algo "(det_wa_wa DWA)" by fact
show ?thesis using step_invar initial_invar step_wf
apply (unfold_locales)
apply (unfold det_wa_wa_def)
apply auto
apply (erule_tac P=wf in back_subst)
apply auto
done
qed
theorem dwa_is_wa:
"while_algo (det_wa_wa DWA) ⟷ det_while_algo DWA"
using det_while_algo_intro det_while_algo.is_while_algo by auto
definition (in det_while_algo)
"loop == (while (dwa_cond WA) (dwa_step WA) (dwa_initial WA))"
lemma (in det_while_algo) while_proof:
assumes inv_imp: "⋀s. ⟦s∈dwa_invar WA; ¬ dwa_cond WA s⟧ ⟹ Q s"
shows "Q loop"
apply (unfold loop_def)
apply (rule_tac P="λx. x∈dwa_invar WA" and
r="{ (dwa_step WA s,s) | s. s∈dwa_invar WA ∧ dwa_cond WA s }"
in while_rule)
apply (simp_all add: step_invar initial_invar step_wf inv_imp)
done
lemma (in det_while_algo) while_proof':
assumes inv_imp:
"∀s. s∈wa_invar (det_wa_wa WA) ∧ s∉wa_cond (det_wa_wa WA) ⟶ Q s"
shows "Q loop"
using inv_imp
apply (simp add: det_wa_wa_def)
apply (blast intro: while_proof)
done
lemma (in det_while_algo) loop_invar:
"loop ∈ dwa_invar WA"
by (rule while_proof) simp
end
Theory SetAbstractionIterator
section ‹\isaheader{Iterators over Representations of Finite Sets}›
theory SetAbstractionIterator
imports Main SetIterator
begin
text ‹Sometimes, an iterator does not iterate over an abstract set directly.
Especialy, if datastructures that are composed of several concrete datastructures
for maps or sets are involved, it might be interesting to iterate over
representations of values instead of the abstract values. This leads to the following construct.›
locale set_iterator_abs_genord =
fixes α :: "'xc ⇒ 'xa"
and invar :: "'xc ⇒ bool"
and iti::"('xc,'σ) set_iterator"
and S0::"'xa set"
and R::"'xa ⇒ 'xa ⇒ bool"
assumes foldli_transform:
"∃lc. (∀xc ∈ set lc. invar xc) ∧
distinct (map α lc) ∧ S0 = set (map α lc) ∧
sorted_wrt R (map α lc) ∧ iti = foldli lc"
begin
text ‹In the simplest case, the function used for iteration does not depend on
the representation, but just the abstract values. In this case, the \emph{normal} iterators
can be used with an adapted function.›
lemma remove_abs :
assumes f_OK: "⋀xc. invar xc ⟹ α xc ∈ S0 ⟹ fc xc = fa (α xc)"
and it_OK: "⋀iti. set_iterator_genord iti S0 R ⟹ P (iti c fa σ0)"
shows "P (iti c fc σ0)"
proof -
from foldli_transform obtain lc where
lc_invar: "⋀xc. xc ∈ set lc ⟹ invar xc"
and α_props: "distinct (map α lc)" "S0 = set (map α lc)"
"sorted_wrt R (map α lc)"
and iti_eq: "iti = foldli lc" by blast
from α_props have "set_iterator_genord (foldli (map α lc)) S0 R"
by (rule_tac set_iterator_genord_I [of "map α lc"]) simp_all
with it_OK have P_OK: "P (foldli (map α lc) c fa σ0)" by blast
from lc_invar f_OK[unfolded α_props(2)]
have "foldli (map α lc) c fa σ0 = foldli lc c fc σ0"
by (induct lc arbitrary: σ0) simp_all
with P_OK iti_eq show ?thesis by simp
qed
text ‹In general, one needs the representation, though. Even in this case,
the construct can be reduced to standard iterators.›
lemma remove_abs2 :
"∃S0'. set_iterator_genord iti S0' (λx y. R (α x) (α y)) ∧
inj_on α S0' ∧ α ` S0' = S0 ∧ (∀x ∈ S0'. invar x)"
proof -
from foldli_transform obtain lc where
lc_invar: "⋀xc. xc ∈ set lc ⟹ invar xc"
and α_props: "distinct (map α lc)" "S0 = set (map α lc)"
"sorted_wrt R (map α lc)"
and iti_eq: "iti = foldli lc" by blast
from α_props have it': "set_iterator_genord iti (set lc) (λx y. R (α x) (α y))"
apply (rule_tac set_iterator_genord_I [of lc])
apply (simp_all add: distinct_map sorted_wrt_map iti_eq)
done
from α_props show ?thesis
apply (rule_tac exI[where x = "set lc"])
apply (simp add: lc_invar distinct_map it')
done
qed
text ‹Let's now derive the inference rules for iterators over representations.›
lemma iteratei_abs_simple_rule_P:
assumes f_OK: "⋀xc. invar xc ⟹ α xc ∈ S0 ⟹ f xc = f' (α xc)"
assumes pre :
"I S0 σ0"
"⋀S σ x. ⟦ c σ; x ∈ S; I S σ; S ⊆ S0;
∀y∈S - {x}. R x y; ∀y∈S0 - S. R y x⟧
⟹ I (S - {x}) (f' x σ)"
"⋀σ. I {} σ ⟹ P σ"
"⋀σ S. ⟦ S ⊆ S0; S ≠ {}; ¬ c σ; I S σ;
∀x∈S. ∀y∈S0-S. R y x ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
apply (rule remove_abs[of f f' P c σ0])
apply (simp add: f_OK)
apply (erule set_iterator_genord.iteratei_rule_P [of _ S0 R I])
apply (simp_all add: pre)
done
lemma iteratei_abs_simple_rule_insert_P:
assumes f_OK: "⋀xc. invar xc ⟹ α xc ∈ S0 ⟹ f xc = f' (α xc)"
assumes pre :
"I {} σ0"
"⋀S σ x. ⟦ c σ; x ∈ S0 - S; I S σ; S ⊆ S0; ∀y∈(S0 - S) - {x}. R x y;
∀y∈S. R y x⟧
⟹ I (insert x S) (f' x σ)"
"⋀σ. I S0 σ ⟹ P σ"
"⋀σ S. ⟦ S ⊆ S0; S ≠ S0;
¬ (c σ); I S σ; ∀x∈S0-S. ∀y∈S. R y x ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
apply (rule remove_abs[of f f' P c σ0])
apply (simp add: f_OK)
apply (erule set_iterator_genord.iteratei_rule_insert_P [of _ S0 R I])
apply (simp_all add: pre)
done
lemma iteratei_abs_rule_P:
assumes pre :
"I S0 σ0"
"⋀S σ x. ⟦ c σ; invar x; α x ∈ S; I S σ; S ⊆ S0;
∀y∈S - {α x}. R (α x) y; ∀y∈S0 - S. R y (α x)⟧
⟹ I (S - {α x}) (f x σ)"
"⋀σ. I {} σ ⟹ P σ"
"⋀σ S. ⟦ S ⊆ S0; S ≠ {}; ¬ c σ; I S σ;
∀x∈S. ∀y∈S0-S. R y x ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
proof -
obtain S0' where S0'_props: "set_iterator_genord iti S0' (λx y. R (α x) (α y))"
"inj_on α S0'" "S0 = α ` S0'" "⋀x. x ∈ S0' ⟹ invar x" by (metis remove_abs2)
show ?thesis
proof (rule set_iterator_genord.iteratei_rule_P[OF S0'_props(1), of "λS σ. I (α ` S) σ" σ0 c], goal_cases)
case 1
thus ?case using S0'_props pre by simp
next
case 3 thus ?case using S0'_props pre by simp
next
case prems: (2 S σ x)
from prems S0'_props have inv_x: "invar x" by blast
from prems(4) have subs_alpha: "α ` S ⊆ α ` S0'" by auto
from S0'_props prems(2,4)
have diff_alpha: "α ` S - {α x} = α ` (S - {x})" "α ` S0' - α ` S = α ` (S0' - S)"
by (auto simp add: inj_on_def subset_iff Ball_def)
show ?case
using pre(2)[of σ x "α ` S"] S0'_props(3)
by (simp add: inv_x prems subs_alpha diff_alpha)
next
case prems: (4 σ S)
show ?case
using pre(4)[of "α ` S" σ] prems S0'_props
by auto
qed
qed
lemma iteratei_abs_rule_insert_P:
assumes pre :
"I {} σ0"
"⋀S σ x. ⟦ c σ; invar x; α x ∈ S0 - S; I S σ; S ⊆ S0;
∀y∈(S0 - S) - {α x}. R (α x) y; ∀y∈S. R y (α x)⟧
⟹ I (insert (α x) S) (f x σ)"
"⋀σ. I S0 σ ⟹ P σ"
"⋀σ S. ⟦ S ⊆ S0; S ≠ S0; ¬ c σ; I S σ;
∀x∈S0-S. ∀y∈S. R y x ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
proof -
obtain S0' where S0'_props: "set_iterator_genord iti S0' (λx y. R (α x) (α y))"
"inj_on α S0'" "S0 = α ` S0'" "⋀x. x ∈ S0' ⟹ invar x" by (metis remove_abs2)
show ?thesis
proof (rule set_iterator_genord.iteratei_rule_insert_P[OF S0'_props(1), of "λS σ. I (α ` S) σ" σ0 c], goal_cases)
case 1
thus ?case using S0'_props pre by simp
next
case 3
thus ?case using S0'_props pre by simp
next
case prems: (2 S σ x)
from prems S0'_props have inv_x: "invar x" by blast
from prems(4) have subs_alpha: "α ` S ⊆ α ` S0'" by auto
from S0'_props prems(2,4)
have diff_alpha: "α ` (S0' - S) - {α x} = α ` ((S0' - S) - {x})" "α ` S0' - α ` S = α ` (S0' - S)"
by (auto simp add: inj_on_def subset_iff Ball_def)
show ?case
using pre(2)[of σ x "α ` S"] prems S0'_props(3)
by (simp add: diff_alpha inv_x subs_alpha)
next
case prems: (4 σ S)
from prems(1) have subs_alpha: "α ` S ⊆ α ` S0'" by auto
from S0'_props prems
have diff_alpha: "α ` S0' - α ` S = α ` (S0' - S)"
by (auto simp add: inj_on_def subset_iff Ball_def)
from prems(1,2) S0'_props(2,3)
have alpha_eq: "α ` S ≠ α ` S0'"
apply (simp add: inj_on_def set_eq_iff image_iff Bex_def subset_iff)
apply blast
done
show ?case
using pre(4)[of "α ` S" σ] S0'_props prems
by (auto simp add: subs_alpha diff_alpha alpha_eq)
qed
qed
end
lemma set_iterator_abs_genord_trivial:
"set_iterator_abs_genord id (λ_. True) = set_iterator_genord"
by (simp add: set_iterator_genord_def set_iterator_abs_genord_def fun_eq_iff)
lemma set_iterator_abs_genord_trivial_simp [simp] :
assumes "∀x. invar x"
and "∀x. α x = x"
shows "set_iterator_abs_genord α invar = set_iterator_genord"
proof -
from assms have "invar = (λ_. True)" and "α = id"
by (simp_all add: fun_eq_iff)
thus ?thesis by (simp add: set_iterator_abs_genord_trivial)
qed
subsection ‹Introduce iterators over representations›
lemma set_iterator_abs_genord_I2 :
assumes it_OK: "set_iterator_genord iti S0 Rc"
and R_OK: "⋀xc1 xc2. ⟦invar xc1; invar xc2; Rc xc1 xc2⟧ ⟹ Ra (α xc1) (α xc2)"
and dist: "⋀xc1 xc2. ⟦invar xc1; invar xc2; xc1 ∈ S0; xc2 ∈ S0; α xc1 = α xc2⟧ ⟹ xc1 = xc2"
and invar: "⋀xc. xc ∈ S0 ⟹ invar xc"
and S0'_eq: "S0' = α ` S0"
shows "set_iterator_abs_genord α invar iti S0' Ra"
proof -
from it_OK obtain l0 where dist_l0: "distinct l0" and
S0_eq: "S0 = set l0" and
sort_Rc: "sorted_wrt Rc l0" and iti_eq: "iti = foldli l0"
unfolding set_iterator_genord_def by auto
have "set l0 ⊆ S0" unfolding S0_eq by simp
with dist_l0 sort_Rc
have map_props: "distinct (map α l0) ∧ sorted_wrt Ra (map α l0)"
proof (induct l0)
case Nil thus ?case by simp
next
case (Cons x l0)
hence "distinct l0" and "x ∉ set l0" and "x ∈ S0" and "set l0 ⊆ S0" and
"distinct (map α l0)" "sorted_wrt Ra (map α l0)" "⋀x'. x' ∈ set l0 ⟹ Rc x x'"
by (simp_all)
thus ?case using dist[of x] R_OK[of x] invar
apply (simp add: image_iff Ball_def subset_iff)
apply metis
done
qed
show ?thesis
unfolding S0'_eq
apply (rule set_iterator_abs_genord.intro)
apply (rule_tac exI[where x = l0])
apply (simp add: iti_eq map_props S0_eq Ball_def invar)
done
qed
subsection ‹Map-Iterators›
lemma map_to_set_cong:
"map_to_set m1 = map_to_set m2 ⟷ m1 = m2"
apply (simp add: set_eq_iff map_to_set_def)
apply (simp add: fun_eq_iff)
apply (metis not_Some_eq)
done
definition "map_iterator_abs_genord α invar it m R ≡
set_iterator_abs_genord (λ(k,v). (k, α v)) (λ(k,v). invar v) it (map_to_set m) R"
lemma map_iterator_abs_genord_I2 :
assumes it_OK: "map_iterator_genord iti m R'"
and invar: "⋀k v. m k = Some v ⟹ invar v"
and R_OK: "⋀k v k' v'. invar v ⟹ invar v' ⟹ R' (k, v) (k', v') ⟹ R (k, α v) (k', α v')"
and m'_eq: "m' = ((map_option α) o m)"
shows "map_iterator_abs_genord α invar iti m' R"
proof -
let ?α' = "λ(k,v). (k, α v)"
let ?invar' = "λ(k,v). invar v"
have α_rewr: "?α' ` (map_to_set m) = map_to_set ((map_option α) o m)"
by (auto simp add: map_to_set_def)
note rule' = set_iterator_abs_genord_I2[OF it_OK[unfolded set_iterator_def],
of ?invar' R ?α' "map_to_set (map_option α ∘ m)", unfolded α_rewr map_iterator_abs_genord_def[symmetric]]
show ?thesis
unfolding m'_eq
apply (rule rule')
apply (auto simp add: map_to_set_def invar R_OK)
done
qed
lemma map_iterator_abs_genord_remove_abs2 :
assumes iti: "map_iterator_abs_genord α invar iti m R"
obtains m' where "map_iterator_genord iti m' (λ(k, v) (k', v'). R (k, α v) (k', α v'))"
"(map_option α) o m' = m" "⋀k v. m' k = Some v ⟹ invar v"
proof -
let ?α' = "λ(k,v). (k, α v)"
let ?invar' = "λ(k,v). invar v"
from set_iterator_abs_genord.foldli_transform [OF iti[unfolded map_iterator_abs_genord_def]]
obtain lc where lc_invar: "⋀k v. (k, v) ∈ set lc ⟹ invar v"
and α_props: "distinct (map ?α' lc)" "map_to_set m = set (map ?α' lc)"
"sorted_wrt R (map ?α' lc)"
and iti_eq: "iti = foldli lc" by blast
from α_props(2)[symmetric] have in_lc: "⋀k v. (k, v) ∈ set lc ⟹ m k = Some (α v)"
by (auto simp add: set_eq_iff image_iff map_to_set_def Ball_def Bex_def)
from α_props(1) have inj_on_α': "inj_on ?α' (set lc)" by (simp add: distinct_map)
from in_lc inj_on_α'
have inj_on_fst: "inj_on fst (set lc)"
apply (simp add: inj_on_def Ball_def)
apply (metis option.inject)
done
let ?m' = "map_of lc"
from α_props have it': "map_iterator_genord iti ?m' (λx y. R (?α' x) (?α' y))"
apply (rule_tac set_iterator_genord_I [of lc])
apply (simp_all add: distinct_map sorted_wrt_map iti_eq map_to_set_map_of inj_on_fst)
done
from inj_on_fst α_props(1)
have "distinct (map fst (map ?α' lc))"
by (auto simp add: distinct_map inj_on_def Ball_def)
hence "map_to_set m = map_to_set (map_of (map ?α' lc))"
by (simp add: α_props map_to_set_map_of)
hence m_eq: "map_option α ∘ map_of lc = m"
by (simp add: map_of_map[symmetric] map_to_set_cong)
from that[of ?m'] it' lc_invar α_props(1) show ?thesis
by (simp add: distinct_map split_def inj_on_fst ran_distinct m_eq)
qed
lemma map_iterator_abs_genord_rule_P:
assumes iti_OK: "map_iterator_abs_genord α invar iti m R"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; invar v; m k = Some (α v); it ⊆ dom m; I it σ;
∀k' v'. k' ∈ it-{k} ∧ invar v' ∧ m k' = Some (α v') ⟶ R (k, α v) (k', α v');
∀k' v'. k' ∉ it ∧ invar v' ∧ m k' = Some (α v') ⟶ R (k', α v') (k, α v)⟧ ⟹
I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ {}; ¬ c σ; I it σ;
∀k v k' v'. k ∉ it ∧ invar v ∧ m k = Some (α v) ∧
k' ∈ it ∧ invar v' ∧ m k' = Some (α v') ⟶
R (k, α v) (k', α v') ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
proof -
let ?α' = "λ(k,v). (k, α v)"
let ?invar' = "λ(k,v). invar v"
from map_iterator_abs_genord_remove_abs2 [OF iti_OK]
obtain m' where m'_props: "map_iterator_genord iti m' (λx y. R (?α' x) (?α' y))"
"m = map_option α ∘ m'" "⋀k v. m' k = Some v ⟹ invar v"
by (auto simp add: split_def)
have dom_m'_eq: "dom m' = dom m"
unfolding m'_props by (simp add: dom_def)
show ?thesis
proof (rule map_iterator_genord_rule_P[OF m'_props(1), of I], goal_cases)
case 1
thus ?case using I0 by (simp add: dom_m'_eq)
next
case 3
thus ?case using IF by simp
next
case prems: (2 k v S σ)
from IP [of σ k S v] prems
show ?case
by (simp add: m'_props) metis
next
case prems: (4 σ S)
show ?case
using II[of S σ] prems
by (simp add: m'_props) metis
qed
qed
lemma map_iterator_abs_genord_rule_insert_P:
assumes iti_OK: "map_iterator_abs_genord α invar iti m R"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ dom m - it; invar v; m k = Some (α v); it ⊆ dom m; I it σ;
∀k' v'. k' ∈ (dom m - it)-{k} ∧ invar v' ∧ m k' = Some (α v') ⟶ R (k, α v) (k', α v');
∀k' v'. k' ∈ it ∧ invar v' ∧ m k' = Some (α v') ⟶ R (k', α v') (k, α v)⟧ ⟹
I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ dom m; ¬ c σ; I it σ;
∀k v k' v'. k ∈ it ∧ invar v ∧ m k = Some (α v) ∧
k' ∉ it ∧ invar v' ∧ m k' = Some (α v') ⟶
R (k, α v) (k', α v') ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
proof -
let ?α' = "λ(k,v). (k, α v)"
let ?invar' = "λ(k,v). invar v"
from map_iterator_abs_genord_remove_abs2 [OF iti_OK]
obtain m' where m'_props: "map_iterator_genord iti m' (λx y. R (?α' x) (?α' y))"
"m = map_option α ∘ m'" "⋀k v. m' k = Some v ⟹ invar v"
by (auto simp add: split_def)
have dom_m'_eq: "dom m' = dom m"
unfolding m'_props by (simp add: dom_def)
show ?thesis
proof (rule map_iterator_genord_rule_insert_P[OF m'_props(1), of I], goal_cases)
case 1
thus ?case using I0 by simp
next
case 3
thus ?case using IF by (simp add: dom_m'_eq)
next
case prems: (2 k v S σ)
from IP [of σ k S v] prems
show ?case
by (simp add: m'_props) metis
next
case prems: (4 σ S)
show ?case
using II[of S σ] prems
by (simp add: m'_props) metis
qed
qed
subsection ‹Unsorted Iterators›
definition "set_iterator_abs α invar it S0 ≡ set_iterator_abs_genord α invar it S0 (λ_ _. True)"
lemma set_iterator_abs_trivial:
"set_iterator_abs id (λ_. True) = set_iterator"
by (simp add: set_iterator_def set_iterator_abs_def fun_eq_iff)
lemma set_iterator_abs_trivial_simp [simp]:
assumes "∀x. invar x"
and "∀x. α x = x"
shows "set_iterator_abs α invar = set_iterator"
proof -
from assms have "invar = (λ_. True)" and "α = id"
by (simp_all add: fun_eq_iff)
thus ?thesis by (simp add: set_iterator_abs_trivial)
qed
lemma set_iterator_abs_I2 :
assumes it_OK: "set_iterator iti S0"
and dist: "⋀xc1 xc2. ⟦invar xc1; invar xc2; xc1 ∈ S0; xc2 ∈ S0; α xc1 = α xc2⟧ ⟹ xc1 = xc2"
and invar: "⋀xc. xc ∈ S0 ⟹ invar xc"
and S0'_OK: "S0' = α ` S0"
shows "set_iterator_abs α invar iti S0'"
unfolding set_iterator_abs_def S0'_OK
apply (rule set_iterator_abs_genord_I2[OF it_OK[unfolded set_iterator_def], of invar _ α])
apply (simp_all add: dist invar)
done
lemma set_iterator_abs_simple_rule_P:
"⟦ set_iterator_abs α invar it S0;
(⋀xc. invar xc ⟹ f xc = f' (α xc));
I S0 σ0;
!!S σ x. ⟦ c σ; x ∈ S; I S σ; S ⊆ S0 ⟧ ⟹ I (S - {x}) (f' x σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_simple_rule_P [of α invar it S0 "λ_ _. True" f f' I σ0 c P]
by simp
lemma set_iterator_abs_simple_no_cond_rule_P:
"⟦ set_iterator_abs α invar it S0;
(⋀xc. invar xc ⟹ f xc = f' (α xc));
I S0 σ0;
!!S σ x. ⟦ x ∈ S; I S σ; S ⊆ S0 ⟧ ⟹ I (S - {x}) (f' x σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (it (λ_. True) f σ0)"
using set_iterator_abs_simple_rule_P[of α invar it S0 f f' I σ0 "λ_. True" P]
by simp
lemma set_iterator_abs_simple_rule_insert_P :
"⟦ set_iterator_abs α invar it S0;
(⋀xc. invar xc ⟹ f xc = f' (α xc));
I {} σ0;
!!S σ x. ⟦ c σ; x ∈ S0 - S; I S σ; S ⊆ S0 ⟧ ⟹ I (insert x S) (f' x σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_simple_rule_insert_P [of α invar it S0 "λ_ _. True" f f' I σ0 c P]
by simp
lemma set_iterator_abs_no_cond_simple_rule_insert_P :
"⟦ set_iterator_abs α invar it S0;
(⋀xc. invar xc ⟹ f xc = f' (α xc));
I {} σ0;
!!S σ x. ⟦ x ∈ S0 - S; I S σ; S ⊆ S0 ⟧ ⟹ I (insert x S) (f' x σ);
!!σ. I S0 σ ⟹ P σ
⟧ ⟹ P (it (λ_. True) f σ0)"
using set_iterator_abs_simple_rule_insert_P[of α invar it S0 f f' I σ0 "λ_. True" P]
by simp
lemma set_iterator_abs_rule_P:
"⟦ set_iterator_abs α invar it S0;
I S0 σ0;
!!S σ x. ⟦ c σ; invar x; α x ∈ S; I S σ; S ⊆ S0 ⟧ ⟹ I (S - {α x}) (f x σ);
!!σ. I {} σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ {} ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_rule_P [of α invar it S0 "λ_ _. True" I σ0 c f P]
by simp
lemma set_iterator_abs_no_cond_rule_P:
"⟦ set_iterator_abs α invar it S0;
I S0 σ0;
!!S σ x. ⟦ invar x; α x ∈ S; I S σ; S ⊆ S0 ⟧ ⟹ I (S - {α x}) (f x σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (it (λ_. True) f σ0)"
using set_iterator_abs_rule_P[of α invar it S0 I σ0 "λ_. True" f P]
by simp
lemma set_iterator_abs_rule_insert_P :
"⟦ set_iterator_abs α invar it S0;
I {} σ0;
!!S σ x. ⟦ c σ; invar x; α x ∈ S0 - S; I S σ; S ⊆ S0 ⟧ ⟹ I (insert (α x) S) (f x σ);
!!σ. I S0 σ ⟹ P σ;
!!σ S. S ⊆ S0 ⟹ S ≠ S0 ⟹ ¬ c σ ⟹ I S σ ⟹ P σ
⟧ ⟹ P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_rule_insert_P [of α invar it S0 "λ_ _. True" I σ0 c f P]
by simp
lemma set_iterator_abs_no_cond_rule_insert_P :
"⟦ set_iterator_abs α invar it S0;
I {} σ0;
!!S σ x. ⟦ invar x; α x ∈ S0 - S; I S σ; S ⊆ S0 ⟧ ⟹ I (insert (α x) S) (f x σ);
!!σ. I S0 σ ⟹ P σ
⟧ ⟹ P (it (λ_. True) f σ0)"
using set_iterator_abs_rule_insert_P[of α invar it S0 I σ0 "λ_. True" f P]
by simp
subsection ‹Unsorted Map-Iterators›
definition "map_iterator_abs α invar it m ≡ map_iterator_abs_genord α invar it m (λ_ _. True)"
lemma map_iterator_abs_trivial:
"map_iterator_abs id (λ_. True) = map_iterator"
by (simp add: set_iterator_def map_iterator_abs_def map_iterator_abs_genord_def
set_iterator_abs_genord_def set_iterator_genord_def fun_eq_iff)
lemma map_iterator_abs_trivial_simp [simp] :
assumes "∀x. invar x"
and "∀x. α x = x"
shows "map_iterator_abs α invar = map_iterator"
proof -
from assms have "invar = (λ_. True)" and "α = id"
by (simp_all add: fun_eq_iff)
thus ?thesis by (simp add: map_iterator_abs_trivial)
qed
lemma map_iterator_abs_I2 :
assumes it_OK: "map_iterator iti m"
and invar: "⋀k v. m k = Some v ⟹ invar v"
and m'_eq: "m' = map_option α ∘ m"
shows "map_iterator_abs α invar iti m'"
using assms
unfolding map_iterator_abs_def set_iterator_def
by (rule_tac map_iterator_abs_genord_I2 [OF it_OK[unfolded set_iterator_def]]) simp_all
lemma map_iterator_abs_rule_P:
assumes iti_OK: "map_iterator_abs α invar iti m"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; invar v; m k = Some (α v); it ⊆ dom m; I it σ ⟧ ⟹
I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
apply (rule map_iterator_abs_genord_rule_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF II)
done
lemma map_iterator_abs_no_cond_rule_P:
assumes iti_OK: "map_iterator_abs α invar iti m"
and I0: "I (dom m) σ0"
and IP: "!!k v it σ. ⟦ k ∈ it; invar v; m k = Some (α v); it ⊆ dom m; I it σ ⟧ ⟹
I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
shows "P (iti (λ_. True) f σ0)"
apply (rule map_iterator_abs_rule_P [OF iti_OK, of I])
apply (simp_all add: I0 IP IF)
done
lemma map_iterator_abs_rule_insert_P:
assumes iti_OK: "map_iterator_abs α invar iti m"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ dom m - it; invar v; m k = Some (α v); it ⊆ dom m; I it σ ⟧ ⟹
I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom m; it ≠ dom m; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (iti c f σ0)"
apply (rule map_iterator_abs_genord_rule_insert_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF II)
done
lemma map_iterator_abs_no_cond_rule_insert_P:
assumes iti_OK: "map_iterator_abs α invar iti m"
and I0: "I {} σ0"
and IP: "!!k v it σ. ⟦ k ∈ dom m - it; invar v; m k = Some (α v); it ⊆ dom m; I it σ ⟧ ⟹
I (insert k it) (f (k, v) σ)"
and IF: "!!σ. I (dom m) σ ⟹ P σ"
shows "P (iti (λ_. True) f σ0)"
apply (rule map_iterator_abs_genord_rule_insert_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF)
done
end
Theory GenCF_Chapter
theory GenCF_Chapter imports Main begin
text_raw ‹\isachapter{The Generic Collection Framework}›
text ‹
The Generic Collection Framework is build on top of the
Automatic Refinement Framework. It contains set and map datastructures that
are fully nestable, and a library of generic algorithms that are
automatically instantiated on demand.
›
end
Theory GenCF_Intf_Chapter
theory GenCF_Intf_Chapter imports Main begin
text_raw ‹\isasection{Interfaces}›
end
Theory Intf_Map
section ‹\isaheader{Map Interface}›
theory Intf_Map
imports Refine_Monadic.Refine_Monadic
begin
consts i_map :: "interface ⇒ interface ⇒ interface"
definition [simp]: "op_map_empty ≡ Map.empty"
definition op_map_lookup :: "'k ⇒ ('k⇀'v) ⇀ 'v"
where [simp]: "op_map_lookup k m ≡ m k"
definition [simp]: "op_map_update k v m ≡ m(k↦v)"
definition [simp]: "op_map_delete k m ≡ m |` (-{k})"
definition [simp]: "op_map_restrict P m ≡ m |` {k∈dom m. P (k, the (m k))}"
definition [simp]: "op_map_isEmpty x ≡ x=Map.empty"
definition [simp]: "op_map_isSng x ≡ ∃k v. x=[k↦v]"
definition [simp]: "op_map_ball m P ≡ Ball (map_to_set m) P"
definition [simp]: "op_map_bex m P ≡ Bex (map_to_set m) P"
definition [simp]: "op_map_size m ≡ card (dom m)"
definition [simp]: "op_map_size_abort n m ≡ min n (card (dom m))"
definition [simp]: "op_map_sel m P ≡ SPEC (λ(k,v). m k = Some v ∧ P k v)"
definition [simp]: "op_map_pick m ≡ SPEC (λ(k,v). m k = Some v)"
definition [simp]: "op_map_pick_remove m ≡
SPEC (λ((k,v),m'). m k = Some v ∧ m' = m |` (-{k}))"
context begin interpretation autoref_syn .
lemma [autoref_op_pat]:
"Map.empty ≡ op_map_empty"
"(m::'k⇀'v) k ≡ op_map_lookup$k$m"
"m(k↦v) ≡ op_map_update$k$v$m"
"m |` (-{k}) ≡ op_map_delete$k$m"
"m |` {k∈dom m. P (k, the (m k))} ≡ op_map_restrict$P$m"
"m=Map.empty ≡ op_map_isEmpty$m"
"Map.empty=m ≡ op_map_isEmpty$m"
"dom m = {} ≡ op_map_isEmpty$m"
"{} = dom m ≡ op_map_isEmpty$m"
"∃k v. m=[k↦v] ≡ op_map_isSng$m"
"∃k v. [k↦v]=m ≡ op_map_isSng$m"
"∃k. dom m={k} ≡ op_map_isSng$m"
"∃k. {k} = dom m ≡ op_map_isSng$m"
"1 = card (dom m) ≡ op_map_isSng$m"
"⋀P. Ball (map_to_set m) P ≡ op_map_ball$m$P"
"⋀P. Bex (map_to_set m) P ≡ op_map_bex$m$P"
"card (dom m) ≡ op_map_size$m"
"min n (card (dom m)) ≡ op_map_size_abort$n$m"
"min (card (dom m)) n ≡ op_map_size_abort$n$m"
"⋀P. SPEC (λ(k,v). m k=Some v ∧ P k v) ≡ op_map_sel$m$P"
"⋀P. SPEC (λ(k,v). P k v ∧ m k=Some v) ≡ op_map_sel$m$P"
"⋀P. SPEC (λ(k,v). m k = Some v) ≡ op_map_pick$m"
"⋀P. SPEC (λ(k,v). (k,v) ∈ map_to_set m) ≡ op_map_pick$m"
by (auto
intro!: eq_reflection ext
simp: restrict_map_def dom_eq_singleton_conv card_Suc_eq map_to_set_def
dest!: sym[of "Suc 0" "card (dom m)"] sym[of _ "dom m"]
)
lemma [autoref_op_pat]:
"SPEC (λ((k,v),m'). m k = Some v ∧ m' = m |` (-{k}))
≡ op_map_pick_remove$m"
by simp
lemma op_map_pick_remove_alt: "
do {((k,v),m) ← op_map_pick_remove m; f k v m}
= (
do {
(k,v)←SPEC (λ(k,v). m k = Some v);
let m=m |` (-{k});
f k v m
})"
unfolding op_map_pick_remove_def
apply (auto simp: pw_eq_iff refine_pw_simps)
done
lemma [autoref_op_pat]:
"do {
(k,v)←SPEC (λ(k,v). m k = Some v);
let m=m |` (-{k});
f k v m
} ≡ do {((k,v),m) ← op_map_pick_remove m; f k v m}"
unfolding op_map_pick_remove_alt .
end
lemma [autoref_itype]:
"op_map_empty ::⇩i ⟨Ik,Iv⟩⇩ii_map"
"op_map_lookup ::⇩i Ik →⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨Iv⟩⇩ii_option"
"op_map_update ::⇩i Ik →⇩i Iv →⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨Ik,Iv⟩⇩ii_map"
"op_map_delete ::⇩i Ik →⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨Ik,Iv⟩⇩ii_map"
"op_map_restrict
::⇩i (⟨Ik,Iv⟩⇩ii_prod →⇩i i_bool) →⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨Ik,Iv⟩⇩ii_map"
"op_map_isEmpty ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i i_bool"
"op_map_isSng ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i i_bool"
"op_map_ball ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i (⟨Ik,Iv⟩⇩ii_prod →⇩i i_bool) →⇩i i_bool"
"op_map_bex ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i (⟨Ik,Iv⟩⇩ii_prod →⇩i i_bool) →⇩i i_bool"
"op_map_size ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i i_nat"
"op_map_size_abort ::⇩i i_nat →⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i i_nat"
"(++) ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨Ik,Iv⟩⇩ii_map"
"map_of ::⇩i ⟨⟨Ik,Iv⟩⇩ii_prod⟩⇩ii_list →⇩i ⟨Ik,Iv⟩⇩ii_map"
"op_map_sel ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i (Ik →⇩i Iv →⇩i i_bool)
→⇩i ⟨⟨Ik,Iv⟩⇩ii_prod⟩⇩ii_nres"
"op_map_pick ::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨⟨Ik,Iv⟩⇩ii_prod⟩⇩ii_nres"
"op_map_pick_remove
::⇩i ⟨Ik,Iv⟩⇩ii_map →⇩i ⟨⟨⟨Ik,Iv⟩⇩ii_prod,⟨Ik,Iv⟩⇩ii_map⟩⇩ii_prod⟩⇩ii_nres"
by simp_all
lemma hom_map1[autoref_hom]:
"CONSTRAINT Map.empty (⟨Rk,Rv⟩Rm)"
"CONSTRAINT map_of (⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨Rk,Rv⟩Rm)"
"CONSTRAINT (++) (⟨Rk,Rv⟩Rm → ⟨Rk,Rv⟩Rm → ⟨Rk,Rv⟩Rm)"
by simp_all
term op_map_restrict
lemma hom_map2[autoref_hom]:
"CONSTRAINT op_map_lookup (Rk→⟨Rk,Rv⟩Rm→⟨Rv⟩option_rel)"
"CONSTRAINT op_map_update (Rk→Rv→⟨Rk,Rv⟩Rm→⟨Rk,Rv⟩Rm)"
"CONSTRAINT op_map_delete (Rk→⟨Rk,Rv⟩Rm→⟨Rk,Rv⟩Rm)"
"CONSTRAINT op_map_restrict ((⟨Rk,Rv⟩prod_rel → Id) → ⟨Rk,Rv⟩Rm → ⟨Rk,Rv⟩Rm)"
"CONSTRAINT op_map_isEmpty (⟨Rk,Rv⟩Rm→Id)"
"CONSTRAINT op_map_isSng (⟨Rk,Rv⟩Rm→Id)"
"CONSTRAINT op_map_ball (⟨Rk,Rv⟩Rm→(⟨Rk,Rv⟩prod_rel→Id)→Id)"
"CONSTRAINT op_map_bex (⟨Rk,Rv⟩Rm→(⟨Rk,Rv⟩prod_rel→Id)→Id)"
"CONSTRAINT op_map_size (⟨Rk,Rv⟩Rm→Id)"
"CONSTRAINT op_map_size_abort (Id→⟨Rk,Rv⟩Rm→Id)"
"CONSTRAINT op_map_sel (⟨Rk,Rv⟩Rm→(Rk → Rv → bool_rel)→⟨Rk×⇩rRv⟩nres_rel)"
"CONSTRAINT op_map_pick (⟨Rk,Rv⟩Rm → ⟨Rk×⇩rRv⟩nres_rel)"
"CONSTRAINT op_map_pick_remove (⟨Rk,Rv⟩Rm → ⟨(Rk×⇩rRv)×⇩r⟨Rk,Rv⟩Rm⟩nres_rel)"
by simp_all
definition "finite_map_rel R ≡ Range R ⊆ Collect (finite ∘ dom)"
lemma finite_map_rel_trigger: "finite_map_rel R ⟹ finite_map_rel R" .
declaration ‹Tagged_Solver.add_triggers
"Relators.relator_props_solver" @{thms finite_map_rel_trigger}›
end
Theory Intf_Set
section ‹\isaheader{Set Interface}›
theory Intf_Set
imports Refine_Monadic.Refine_Monadic
begin
consts i_set :: "interface ⇒ interface"
lemmas [autoref_rel_intf] = REL_INTFI[of set_rel i_set]
definition [simp]: "op_set_delete x s ≡ s - {x}"
definition [simp]: "op_set_isEmpty s ≡ s = {}"
definition [simp]: "op_set_isSng s ≡ card s = 1"
definition [simp]: "op_set_size_abort m s ≡ min m (card s)"
definition [simp]: "op_set_disjoint a b ≡ a∩b={}"
definition [simp]: "op_set_filter P s ≡ {x∈s. P x}"
definition [simp]: "op_set_sel P s ≡ SPEC (λx. x∈s ∧ P x)"
definition [simp]: "op_set_pick s ≡ SPEC (λx. x∈s)"
definition [simp]: "op_set_to_sorted_list ordR s
≡ SPEC (λl. set l = s ∧ distinct l ∧ sorted_wrt ordR l)"
definition [simp]: "op_set_to_list s ≡ SPEC (λl. set l = s ∧ distinct l)"
definition [simp]: "op_set_cart x y ≡ x × y"
context begin interpretation autoref_syn .
lemma [autoref_op_pat]:
fixes s a b :: "'a set" and x::'a and P :: "'a ⇒ bool"
shows
"s - {x} ≡ op_set_delete$x$s"
"s = {} ≡ op_set_isEmpty$s"
"{}=s ≡ op_set_isEmpty$s"
"card s = 1 ≡ op_set_isSng$s"
"∃x. s={x} ≡ op_set_isSng$s"
"∃x. {x}=s ≡ op_set_isSng$s"
"min m (card s) ≡ op_set_size_abort$m$s"
"min (card s) m ≡ op_set_size_abort$m$s"
"a∩b={} ≡ op_set_disjoint$a$b"
"{x∈s. P x} ≡ op_set_filter$P$s"
"SPEC (λx. x∈s ∧ P x) ≡ op_set_sel$P$s"
"SPEC (λx. P x ∧ x∈s) ≡ op_set_sel$P$s"
"SPEC (λx. x∈s) ≡ op_set_pick$s"
by (auto intro!: eq_reflection simp: card_Suc_eq)
lemma [autoref_op_pat]:
"a × b ≡ op_set_cart a b"
by (auto intro!: eq_reflection simp: card_Suc_eq)
lemma [autoref_op_pat]:
"SPEC (λ(u,v). (u,v)∈s) ≡ op_set_pick$s"
"SPEC (λ(u,v). P u v ∧ (u,v)∈s) ≡ op_set_sel$(case_prod P)$s"
"SPEC (λ(u,v). (u,v)∈s ∧ P u v) ≡ op_set_sel$(case_prod P)$s"
by (auto intro!: eq_reflection)
lemma [autoref_op_pat]:
"SPEC (λl. set l = s ∧ distinct l ∧ sorted_wrt ordR l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. set l = s ∧ sorted_wrt ordR l ∧ distinct l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. distinct l ∧ set l = s ∧ sorted_wrt ordR l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. distinct l ∧ sorted_wrt ordR l ∧ set l = s)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. sorted_wrt ordR l ∧ distinct l ∧ set l = s)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. sorted_wrt ordR l ∧ set l = s ∧ distinct l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. s = set l ∧ distinct l ∧ sorted_wrt ordR l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. s = set l ∧ sorted_wrt ordR l ∧ distinct l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. distinct l ∧ s = set l ∧ sorted_wrt ordR l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. distinct l ∧ sorted_wrt ordR l ∧ s = set l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. sorted_wrt ordR l ∧ distinct l ∧ s = set l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. sorted_wrt ordR l ∧ s = set l ∧ distinct l)
≡ OP (op_set_to_sorted_list ordR)$s"
"SPEC (λl. set l = s ∧ distinct l) ≡ op_set_to_list$s"
"SPEC (λl. distinct l ∧ set l = s) ≡ op_set_to_list$s"
"SPEC (λl. s = set l ∧ distinct l) ≡ op_set_to_list$s"
"SPEC (λl. distinct l ∧ s = set l) ≡ op_set_to_list$s"
by (auto intro!: eq_reflection)
end
lemma [autoref_itype]:
"{} ::⇩i ⟨I⟩⇩ii_set"
"insert ::⇩i I →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"op_set_delete ::⇩i I →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"(∈) ::⇩i I →⇩i ⟨I⟩⇩ii_set →⇩i i_bool"
"op_set_isEmpty ::⇩i ⟨I⟩⇩ii_set →⇩i i_bool"
"op_set_isSng ::⇩i ⟨I⟩⇩ii_set →⇩i i_bool"
"(∪) ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"(∩) ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"((-) :: 'a set ⇒ 'a set ⇒ 'a set) ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"((=) :: 'a set ⇒ 'a set ⇒ bool) ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set →⇩i i_bool"
"(⊆) ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set →⇩i i_bool"
"op_set_disjoint ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set →⇩i i_bool"
"Ball ::⇩i ⟨I⟩⇩ii_set →⇩i (I →⇩i i_bool) →⇩i i_bool"
"Bex ::⇩i ⟨I⟩⇩ii_set →⇩i (I →⇩i i_bool) →⇩i i_bool"
"op_set_filter ::⇩i (I →⇩i i_bool) →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"card ::⇩i ⟨I⟩⇩ii_set →⇩i i_nat"
"op_set_size_abort ::⇩i i_nat →⇩i ⟨I⟩⇩ii_set →⇩i i_nat"
"set ::⇩i ⟨I⟩⇩ii_list →⇩i ⟨I⟩⇩ii_set"
"op_set_sel ::⇩i (I →⇩i i_bool) →⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_nres"
"op_set_pick ::⇩i ⟨I⟩⇩ii_set →⇩i ⟨I⟩⇩ii_nres"
"Sigma ::⇩i ⟨Ia⟩⇩ii_set →⇩i (Ia →⇩i ⟨Ib⟩⇩ii_set) →⇩i ⟨⟨Ia,Ib⟩⇩ii_prod⟩⇩ii_set"
"(`) ::⇩i (Ia→⇩iIb) →⇩i ⟨Ia⟩⇩ii_set →⇩i ⟨Ib⟩⇩ii_set"
"op_set_cart ::⇩i ⟨Ix⟩⇩iIsx →⇩i ⟨Iy⟩⇩iIsy →⇩i ⟨⟨Ix, Iy⟩⇩ii_prod⟩⇩iIsp"
"Union ::⇩i ⟨⟨I⟩⇩ii_set⟩⇩ii_set →⇩i ⟨I⟩⇩ii_set"
"atLeastLessThan ::⇩i i_nat →⇩i i_nat →⇩i ⟨i_nat⟩⇩ii_set"
by simp_all
lemma hom_set1[autoref_hom]:
"CONSTRAINT {} (⟨R⟩Rs)"
"CONSTRAINT insert (R→⟨R⟩Rs→⟨R⟩Rs)"
"CONSTRAINT (∈) (R→⟨R⟩Rs→Id)"
"CONSTRAINT (∪) (⟨R⟩Rs→⟨R⟩Rs→⟨R⟩Rs)"
"CONSTRAINT (∩) (⟨R⟩Rs→⟨R⟩Rs→⟨R⟩Rs)"
"CONSTRAINT (-) (⟨R⟩Rs→⟨R⟩Rs→⟨R⟩Rs)"
"CONSTRAINT (=) (⟨R⟩Rs→⟨R⟩Rs→Id)"
"CONSTRAINT (⊆) (⟨R⟩Rs→⟨R⟩Rs→Id)"
"CONSTRAINT Ball (⟨R⟩Rs→(R→Id)→Id)"
"CONSTRAINT Bex (⟨R⟩Rs→(R→Id)→Id)"
"CONSTRAINT card (⟨R⟩Rs→Id)"
"CONSTRAINT set (⟨R⟩Rl→⟨R⟩Rs)"
"CONSTRAINT (`) ((Ra→Rb) → ⟨Ra⟩Rs→⟨Rb⟩Rs)"
"CONSTRAINT Union (⟨⟨R⟩Ri⟩Ro → ⟨R⟩Ri)"
by simp_all
lemma hom_set2[autoref_hom]:
"CONSTRAINT op_set_delete (R→⟨R⟩Rs→⟨R⟩Rs)"
"CONSTRAINT op_set_isEmpty (⟨R⟩Rs→Id)"
"CONSTRAINT op_set_isSng (⟨R⟩Rs→Id)"
"CONSTRAINT op_set_size_abort (Id→⟨R⟩Rs→Id)"
"CONSTRAINT op_set_disjoint (⟨R⟩Rs→⟨R⟩Rs→Id)"
"CONSTRAINT op_set_filter ((R→Id)→⟨R⟩Rs→⟨R⟩Rs)"
"CONSTRAINT op_set_sel ((R → Id)→⟨R⟩Rs→⟨R⟩Rn)"
"CONSTRAINT op_set_pick (⟨R⟩Rs→⟨R⟩Rn)"
by simp_all
lemma hom_set_Sigma[autoref_hom]:
"CONSTRAINT Sigma (⟨Ra⟩Rs → (Ra → ⟨Rb⟩Rs) → ⟨⟨Ra,Rb⟩prod_rel⟩Rs2)"
by simp_all
definition "finite_set_rel R ≡ Range R ⊆ Collect (finite)"
lemma finite_set_rel_trigger: "finite_set_rel R ⟹ finite_set_rel R" .
declaration ‹Tagged_Solver.add_triggers
"Relators.relator_props_solver" @{thms finite_set_rel_trigger}›
end
Theory Intf_Hash
section ‹\isaheader{Hashable Interface}›
theory Intf_Hash
imports
Main
"../../Lib/HashCode"
"../../Lib/Code_Target_ICF"
Automatic_Refinement.Automatic_Refinement
begin
type_synonym 'a eq = "'a ⇒ 'a ⇒ bool"
type_synonym 'k bhc = "nat ⇒ 'k ⇒ nat"
subsection ‹Abstract and concrete hash functions›
definition is_bounded_hashcode :: "('c×'a) set ⇒ 'c eq ⇒ 'c bhc ⇒ bool"
where "is_bounded_hashcode R eq bhc ≡
((eq,(=)) ∈ R → R → bool_rel) ∧
(∀n. ∀ x ∈ Domain R. ∀ y ∈ Domain R. eq x y ⟶ bhc n x = bhc n y) ∧
(∀n x. 1 < n ⟶ bhc n x < n)"
definition abstract_bounded_hashcode :: "('c×'a) set ⇒ 'c bhc ⇒ 'a bhc"
where "abstract_bounded_hashcode Rk bhc n x' ≡
if x' ∈ Range Rk
then THE c. ∃x. (x,x') ∈ Rk ∧ bhc n x = c
else 0"
lemma is_bounded_hashcodeI[intro]:
"((eq,(=)) ∈ R → R → bool_rel) ⟹
(⋀x y n. x ∈ Domain R ⟹ y ∈ Domain R ⟹ eq x y ⟹ bhc n x = bhc n y) ⟹
(⋀x n. 1 < n ⟹ bhc n x < n) ⟹ is_bounded_hashcode R eq bhc"
unfolding is_bounded_hashcode_def by force
lemma is_bounded_hashcodeD[dest]:
assumes "is_bounded_hashcode R eq bhc"
shows "(eq,(=)) ∈ R → R → bool_rel" and
"⋀n x y. x ∈ Domain R ⟹ y ∈ Domain R ⟹ eq x y ⟹ bhc n x = bhc n y" and
"⋀n x. 1 < n ⟹ bhc n x < n"
using assms unfolding is_bounded_hashcode_def by simp_all
lemma bounded_hashcode_welldefined:
assumes BHC: "is_bounded_hashcode Rk eq bhc" and
R1: "(x1,x') ∈ Rk" and R2: "(x2,x') ∈ Rk"
shows "bhc n x1 = bhc n x2"
proof-
from is_bounded_hashcodeD[OF BHC] have "(eq,(=)) ∈ Rk → Rk → bool_rel" by simp
with R1 R2 have "eq x1 x2" by (force dest: fun_relD)
thus ?thesis using R1 R2 BHC by blast
qed
lemma abstract_bhc_correct[intro]:
assumes "is_bounded_hashcode Rk eq bhc"
shows "(bhc, abstract_bounded_hashcode Rk bhc) ∈
nat_rel → Rk → nat_rel" (is "(bhc, ?bhc') ∈ _")
proof (intro fun_relI)
fix n n' x x'
assume A: "(n,n') ∈ nat_rel" and B: "(x,x') ∈ Rk"
hence C: "n = n'" and D: "x' ∈ Range Rk" by auto
have "?bhc' n' x' = bhc n x"
unfolding abstract_bounded_hashcode_def
apply (simp add: C D, rule)
apply (intro exI conjI, fact B, rule refl)
apply (elim exE conjE, hypsubst,
erule bounded_hashcode_welldefined[OF assms _ B])
done
thus "(bhc n x, ?bhc' n' x') ∈ nat_rel" by simp
qed
lemma abstract_bhc_is_bhc[intro]:
fixes Rk :: "('c×'a) set"
assumes bhc: "is_bounded_hashcode Rk eq bhc"
shows "is_bounded_hashcode Id (=) (abstract_bounded_hashcode Rk bhc)"
(is "is_bounded_hashcode _ (=) ?bhc'")
proof
fix x'::'a and y'::'a and n'::nat assume "x' = y'"
thus "?bhc' n' x' = ?bhc' n' y'" by simp
next
fix x'::'a and n'::nat assume "1 < n'"
from abstract_bhc_correct[OF bhc] show "?bhc' n' x' < n'"
proof (cases "x' ∈ Range Rk")
case False
with ‹1 < n'› show ?thesis
unfolding abstract_bounded_hashcode_def by simp
next
case True
then obtain x where "(x,x') ∈ Rk" ..
have "(n',n') ∈ nat_rel" ..
from abstract_bhc_correct[OF assms] have "?bhc' n' x' = bhc n' x"
apply -
apply (drule fun_relD[OF _ ‹(n',n') ∈ nat_rel›],
drule fun_relD[OF _ ‹(x,x') ∈ Rk›], simp)
done
also from ‹1 < n'› and bhc have "... < n'" by blast
finally show "?bhc' n' x' < n'" .
qed
qed simp
lemma hashable_bhc_is_bhc[autoref_ga_rules]:
"⟦STRUCT_EQ_tag eq (=); REL_FORCE_ID R⟧ ⟹ is_bounded_hashcode R eq bounded_hashcode_nat"
unfolding is_bounded_hashcode_def
by (simp add: bounded_hashcode_nat_bounds)
subsection ‹Default hash map size›
definition is_valid_def_hm_size :: "'k itself ⇒ nat ⇒ bool"
where "is_valid_def_hm_size type n ≡ n > 1"
lemma hashable_def_size_is_def_size[autoref_ga_rules]:
shows "is_valid_def_hm_size TYPE('k::hashable) (def_hashmap_size TYPE('k))"
unfolding is_valid_def_hm_size_def by (fact def_hashmap_size)
end
Theory Intf_Comp
section ‹\isaheader{Orderings By Comparison Operator}›
theory Intf_Comp
imports
Automatic_Refinement.Automatic_Refinement
begin
subsection ‹Basic Definitions›
datatype comp_res = LESS | EQUAL | GREATER
consts i_comp_res :: interface
abbreviation "comp_res_rel ≡ Id :: (comp_res × _) set"
lemmas [autoref_rel_intf] = REL_INTFI[of comp_res_rel i_comp_res]
definition "comp2le cmp a b ≡
case cmp a b of LESS ⇒ True | EQUAL ⇒ True | GREATER ⇒ False"
definition "comp2lt cmp a b ≡
case cmp a b of LESS ⇒ True | EQUAL ⇒ False | GREATER ⇒ False"
definition "comp2eq cmp a b ≡
case cmp a b of LESS ⇒ False | EQUAL ⇒ True | GREATER ⇒ False"
locale linorder_on =
fixes D :: "'a set"
fixes cmp :: "'a ⇒ 'a ⇒ comp_res"
assumes lt_eq: "⟦x∈D; y∈D⟧ ⟹ cmp x y = LESS ⟷ (cmp y x = GREATER)"
assumes refl[simp, intro!]: "x∈D ⟹ cmp x x = EQUAL"
assumes trans[trans]:
"⟦ x∈D; y∈D; z∈D; cmp x y = LESS; cmp y z = LESS⟧ ⟹ cmp x z = LESS"
"⟦ x∈D; y∈D; z∈D; cmp x y = LESS; cmp y z = EQUAL⟧ ⟹ cmp x z = LESS"
"⟦ x∈D; y∈D; z∈D; cmp x y = EQUAL; cmp y z = LESS⟧ ⟹ cmp x z = LESS"
"⟦ x∈D; y∈D; z∈D; cmp x y = EQUAL; cmp y z = EQUAL⟧ ⟹ cmp x z = EQUAL"
begin
abbreviation "le ≡ comp2le cmp"
abbreviation "lt ≡ comp2lt cmp"
lemma eq_sym: "⟦x∈D; y∈D⟧ ⟹ cmp x y = EQUAL ⟹ cmp y x = EQUAL"
apply (cases "cmp y x")
using lt_eq lt_eq[symmetric]
by auto
end
abbreviation "linorder ≡ linorder_on UNIV"
lemma linorder_to_class:
assumes "linorder cmp"
assumes [simp]: "⋀x y. cmp x y = EQUAL ⟹ x=y"
shows "class.linorder (comp2le cmp) (comp2lt cmp)"
proof -
interpret linorder_on UNIV cmp by fact
show ?thesis
apply (unfold_locales)
unfolding comp2le_def comp2lt_def
apply (auto split: comp_res.split comp_res.split_asm)
using lt_eq apply simp
using lt_eq apply simp
using lt_eq[symmetric] apply simp
apply (drule (1) trans[rotated 3], simp_all) []
apply (drule (1) trans[rotated 3], simp_all) []
apply (drule (1) trans[rotated 3], simp_all) []
apply (drule (1) trans[rotated 3], simp_all) []
using lt_eq apply simp
using lt_eq apply simp
using lt_eq[symmetric] apply simp
done
qed
definition "dflt_cmp le lt a b ≡
if lt a b then LESS
else if le a b then EQUAL
else GREATER"
lemma (in linorder) class_to_linorder:
"linorder (dflt_cmp (≤) (<))"
apply (unfold_locales)
unfolding dflt_cmp_def
by (auto split: if_split_asm)
lemma restrict_linorder: "⟦linorder_on D cmp ; D'⊆D⟧ ⟹ linorder_on D' cmp"
apply (rule linorder_on.intro)
apply (drule (1) rev_subsetD)+
apply (erule (2) linorder_on.lt_eq)
apply (drule (1) rev_subsetD)+
apply (erule (1) linorder_on.refl)
apply (drule (1) rev_subsetD)+
apply (erule (5) linorder_on.trans)
apply (drule (1) rev_subsetD)+
apply (erule (5) linorder_on.trans)
apply (drule (1) rev_subsetD)+
apply (erule (5) linorder_on.trans)
apply (drule (1) rev_subsetD)+
apply (erule (5) linorder_on.trans)
done
subsection ‹Operations on Linear Orderings›
text ‹Map with injective function›
definition cmp_img where "cmp_img f cmp a b ≡ cmp (f a) (f b)"
lemma img_linorder[intro?]:
assumes LO: "linorder_on (f`D) cmp"
shows "linorder_on D (cmp_img f cmp)"
apply unfold_locales
unfolding cmp_img_def
apply (rule linorder_on.lt_eq[OF LO], auto) []
apply (rule linorder_on.refl[OF LO], auto) []
apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
done
text ‹Combine›
definition "cmp_combine D1 cmp1 D2 cmp2 a b ≡
if a∈D1 ∧ b∈D1 then cmp1 a b
else if a∈D1 ∧ b∈D2 then LESS
else if a∈D2 ∧ b∈D1 then GREATER
else cmp2 a b
"
lemma UnE':
assumes "x∈A∪B"
obtains "x∈A" | "x∉A" "x∈B"
using assms by blast
lemma combine_linorder[intro?]:
assumes "linorder_on D1 cmp1"
assumes "linorder_on D2 cmp2"
assumes "D = D1∪D2"
shows "linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
apply unfold_locales
unfolding cmp_combine_def
using assms apply -
apply (simp only:)
apply (elim UnE)
apply (auto dest: linorder_on.lt_eq) [4]
apply (simp only:)
apply (elim UnE)
apply (auto dest: linorder_on.refl) [2]
apply (simp only:)
apply (elim UnE')
apply simp_all [8]
apply (erule (5) linorder_on.trans)
apply (erule (5) linorder_on.trans)
apply (simp only:)
apply (elim UnE')
apply simp_all [8]
apply (erule (5) linorder_on.trans)
apply (erule (5) linorder_on.trans)
apply (simp only:)
apply (elim UnE')
apply simp_all [8]
apply (erule (5) linorder_on.trans)
apply (erule (5) linorder_on.trans)
apply (simp only:)
apply (elim UnE')
apply simp_all [8]
apply (erule (5) linorder_on.trans)
apply (erule (5) linorder_on.trans)
done
subsection ‹Universal Linear Ordering›
text ‹With Zorn's Lemma, we get a universal linear (even wf) ordering›
definition "univ_order_rel ≡ (SOME r. well_order_on UNIV r)"
definition "univ_cmp x y ≡
if x=y then EQUAL
else if (x,y)∈univ_order_rel then LESS
else GREATER"
lemma univ_wo: "well_order_on UNIV univ_order_rel"
unfolding univ_order_rel_def
using well_order_on[of UNIV]
..
lemma univ_linorder[intro?]: "linorder univ_cmp"
apply unfold_locales
unfolding univ_cmp_def
apply (auto split: if_split_asm)
using univ_wo
apply -
unfolding well_order_on_def linear_order_on_def partial_order_on_def
preorder_on_def
apply (auto simp add: antisym_def) []
apply (unfold total_on_def, fast) []
apply (unfold trans_def, fast) []
apply (auto simp add: antisym_def) []
done
text ‹Extend any linear order to a universal order›
definition "cmp_extend D cmp ≡
cmp_combine D cmp UNIV univ_cmp"
lemma extend_linorder[intro?]:
"linorder_on D cmp ⟹ linorder (cmp_extend D cmp)"
unfolding cmp_extend_def
apply rule
apply assumption
apply rule
by simp
subsubsection ‹Lexicographic Order on Lists›
fun cmp_lex where
"cmp_lex cmp [] [] = EQUAL"
| "cmp_lex cmp [] _ = LESS"
| "cmp_lex cmp _ [] = GREATER"
| "cmp_lex cmp (a#l) (b#m) = (
case cmp a b of
LESS ⇒ LESS
| EQUAL ⇒ cmp_lex cmp l m
| GREATER ⇒ GREATER)"
primrec cmp_lex' where
"cmp_lex' cmp [] m = (case m of [] ⇒ EQUAL | _ ⇒ LESS)"
| "cmp_lex' cmp (a#l) m = (case m of [] ⇒ GREATER | (b#m) ⇒
(case cmp a b of
LESS ⇒ LESS
| EQUAL ⇒ cmp_lex' cmp l m
| GREATER ⇒ GREATER
))"
lemma cmp_lex_alt: "cmp_lex cmp l m = cmp_lex' cmp l m"
apply (induct l arbitrary: m)
apply (auto split: comp_res.split list.split)
done
lemma (in linorder_on) lex_linorder[intro?]:
"linorder_on (lists D) (cmp_lex cmp)"
proof
fix l m
assume "l∈lists D" "m∈lists D"
thus "(cmp_lex cmp l m = LESS) = (cmp_lex cmp m l = GREATER)"
apply (induct cmp≡cmp l m rule: cmp_lex.induct)
apply (auto split: comp_res.split simp: lt_eq)
apply (auto simp: lt_eq[symmetric])
done
next
fix x
assume "x∈lists D"
thus "cmp_lex cmp x x = EQUAL"
by (induct x) auto
next
fix x y z
assume M: "x∈lists D" "y∈lists D" "z∈lists D"
{
assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = LESS"
thus "cmp_lex cmp x z = LESS"
using M
apply (induct cmp≡cmp x y arbitrary: z rule: cmp_lex.induct)
apply (auto split: comp_res.split_asm comp_res.split)
apply (case_tac z, auto) []
apply (case_tac z,
auto split: comp_res.split_asm comp_res.split,
(drule (4) trans, simp)+
) []
apply (case_tac z,
auto split: comp_res.split_asm comp_res.split,
(drule (4) trans, simp)+
) []
done
}
{
assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = EQUAL"
thus "cmp_lex cmp x z = LESS"
using M
apply (induct cmp≡cmp x y arbitrary: z rule: cmp_lex.induct)
apply (auto split: comp_res.split_asm comp_res.split)
apply (case_tac z, auto) []
apply (case_tac z,
auto split: comp_res.split_asm comp_res.split,
(drule (4) trans, simp)+
) []
apply (case_tac z,
auto split: comp_res.split_asm comp_res.split,
(drule (4) trans, simp)+
) []
done
}
{
assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = LESS"
thus "cmp_lex cmp x z = LESS"
using M
apply (induct cmp≡cmp x y arbitrary: z rule: cmp_lex.induct)
apply (auto split: comp_res.split_asm comp_res.split)
apply (case_tac z,
auto split: comp_res.split_asm comp_res.split,
(drule (4) trans, simp)+
) []
done
}
{
assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = EQUAL"
thus "cmp_lex cmp x z = EQUAL"
using M
apply (induct cmp≡cmp x y arbitrary: z rule: cmp_lex.induct)
apply (auto split: comp_res.split_asm comp_res.split)
apply (case_tac z)
apply (auto split: comp_res.split_asm comp_res.split)
apply (drule (4) trans, simp)+
done
}
qed
subsubsection ‹Lexicographic Order on Pairs›
fun cmp_prod where
"cmp_prod cmp1 cmp2 (a1,a2) (b1,b2)
= (
case cmp1 a1 b1 of
LESS ⇒ LESS
| EQUAL ⇒ cmp2 a2 b2
| GREATER ⇒ GREATER)"
lemma cmp_prod_alt: "cmp_prod = (λcmp1 cmp2 (a1,a2) (b1,b2). (
case cmp1 a1 b1 of
LESS ⇒ LESS
| EQUAL ⇒ cmp2 a2 b2
| GREATER ⇒ GREATER))"
by (auto intro!: ext)
lemma prod_linorder[intro?]:
assumes A: "linorder_on A cmp1"
assumes B: "linorder_on B cmp2"
shows "linorder_on (A×B) (cmp_prod cmp1 cmp2)"
proof -
interpret A: linorder_on A cmp1
+ B: linorder_on B cmp2 by fact+
show ?thesis
apply unfold_locales
apply (auto split: comp_res.split comp_res.split_asm,
simp_all add: A.lt_eq B.lt_eq,
simp_all add: A.lt_eq[symmetric]
) []
apply (auto split: comp_res.split comp_res.split_asm) []
apply (auto split: comp_res.split comp_res.split_asm) []
apply (drule (4) A.trans B.trans, simp)+
apply (auto split: comp_res.split comp_res.split_asm) []
apply (drule (4) A.trans B.trans, simp)+
apply (auto split: comp_res.split comp_res.split_asm) []
apply (drule (4) A.trans B.trans, simp)+
apply (auto split: comp_res.split comp_res.split_asm) []
apply (drule (4) A.trans B.trans, simp)+
done
qed
subsection ‹Universal Ordering for Sets that is Effective for Finite Sets›
subsubsection ‹Sorted Lists of Sets›
text ‹Some more results about sorted lists of finite sets›
lemma set_to_map_set_is_map_of:
"distinct (map fst l) ⟹ set_to_map (set l) = map_of l"
apply (induct l)
apply (auto simp: set_to_map_insert)
done
context linorder begin
lemma sorted_list_of_set_eq_nil[simp]:
assumes "finite A"
shows "sorted_list_of_set A = [] ⟷ A={}"
using assms
apply (induct rule: finite_induct)
apply simp
apply simp
done
lemma sorted_list_of_set_eq_nil2[simp]:
assumes "finite A"
shows "[] = sorted_list_of_set A ⟷ A={}"
using assms
by (auto dest: sym)
lemma set_insort[simp]: "set (insort x l) = insert x (set l)"
by (induct l) auto
lemma sorted_list_of_set_inj_aux:
fixes A B :: "'a set"
assumes "finite A"
assumes "finite B"
assumes "sorted_list_of_set A = sorted_list_of_set B"
shows "A=B"
using assms
proof -
from ‹finite B› have "B = set (sorted_list_of_set B)" by simp
also from assms have "… = set (sorted_list_of_set (A))"
by simp
also from ‹finite A›
have "set (sorted_list_of_set (A)) = A"
by simp
finally show ?thesis by simp
qed
lemma sorted_list_of_set_inj: "inj_on sorted_list_of_set (Collect finite)"
apply (rule inj_onI)
using sorted_list_of_set_inj_aux
by blast
lemma the_sorted_list_of_set:
assumes "distinct l"
assumes "sorted l"
shows "sorted_list_of_set (set l) = l"
using assms
by (simp
add: sorted_list_of_set_sort_remdups distinct_remdups_id sorted_sort_id)
definition "sorted_list_of_map m ≡
map (λk. (k, the (m k))) (sorted_list_of_set (dom m))"
lemma the_sorted_list_of_map:
assumes "distinct (map fst l)"
assumes "sorted (map fst l)"
shows "sorted_list_of_map (map_of l) = l"
proof -
have "dom (map_of l) = set (map fst l)" by (induct l) force+
hence "sorted_list_of_set (dom (map_of l)) = map fst l"
using the_sorted_list_of_set[OF assms] by simp
hence "sorted_list_of_map (map_of l)
= map (λk. (k, the (map_of l k))) (map fst l)"
unfolding sorted_list_of_map_def by simp
also have "… = l" using ‹distinct (map fst l)›
proof (induct l)
case Nil thus ?case by simp
next
case (Cons a l)
hence
1: "distinct (map fst l)"
and 2: "fst a∉fst`set l"
and 3: "map (λk. (k, the (map_of l k))) (map fst l) = l"
by simp_all
from 2 have [simp]: "¬(∃x∈set l. fst x = fst a)"
by (auto simp: image_iff)
show ?case
apply simp
apply (subst (3) 3[symmetric])
apply simp
done
qed
finally show ?thesis .
qed
lemma map_of_sorted_list_of_map[simp]:
assumes FIN: "finite (dom m)"
shows "map_of (sorted_list_of_map m) = m"
unfolding sorted_list_of_map_def
proof -
have "set (sorted_list_of_set (dom m)) = dom m"
and DIST: "distinct (sorted_list_of_set (dom m))"
by (simp_all add: FIN)
have [simp]: "(fst ∘ (λk. (k, the (m k)))) = id" by auto
have [simp]: "(λk. (k, the (m k))) ` dom m = map_to_set m"
by (auto simp: map_to_set_def)
show "map_of (map (λk. (k, the (m k))) (sorted_list_of_set (dom m))) = m"
apply (subst set_to_map_set_is_map_of[symmetric])
apply (simp add: DIST)
apply (subst set_map)
apply (simp add: FIN map_to_set_inverse)
done
qed
lemma sorted_list_of_map_inj_aux:
fixes A B :: "'a⇀'b"
assumes [simp]: "finite (dom A)"
assumes [simp]: "finite (dom B)"
assumes E: "sorted_list_of_map A = sorted_list_of_map B"
shows "A=B"
using assms
proof -
have "A = map_of (sorted_list_of_map A)" by simp
also note E
also have "map_of (sorted_list_of_map B) = B" by simp
finally show ?thesis .
qed
lemma sorted_list_of_map_inj:
"inj_on sorted_list_of_map (Collect (finite o dom))"
apply (rule inj_onI)
using sorted_list_of_map_inj_aux
by auto
end
definition "cmp_set cmp ≡
cmp_extend (Collect finite) (
cmp_img
(linorder.sorted_list_of_set (comp2le cmp))
(cmp_lex cmp)
)"
thm img_linorder
lemma set_ord_linear[intro?]:
"linorder cmp ⟹ linorder (cmp_set cmp)"
unfolding cmp_set_def
apply rule
apply rule
apply (rule restrict_linorder)
apply (erule linorder_on.lex_linorder)
apply simp
done
definition "cmp_map cmpk cmpv ≡
cmp_extend (Collect (finite o dom)) (
cmp_img
(linorder.sorted_list_of_map (comp2le cmpk))
(cmp_lex (cmp_prod cmpk cmpv))
)
"
lemma map_to_set_inj[intro!]: "inj map_to_set"
apply (rule inj_onI)
unfolding map_to_set_def
apply (rule ext)
apply (case_tac "x xa")
apply (case_tac [!] "y xa")
apply force+
done
corollary map_to_set_inj'[intro!]: "inj_on map_to_set S"
by (metis map_to_set_inj subset_UNIV subset_inj_on)
lemma map_ord_linear[intro?]:
assumes A: "linorder cmpk"
assumes B: "linorder cmpv"
shows "linorder (cmp_map cmpk cmpv)"
proof -
interpret lk: linorder_on UNIV cmpk by fact
interpret lv: linorder_on UNIV cmpv by fact
show ?thesis
unfolding cmp_map_def
apply rule
apply rule
apply (rule restrict_linorder)
apply (rule linorder_on.lex_linorder)
apply (rule)
apply fact
apply fact
apply simp
done
qed
locale eq_linorder_on = linorder_on +
assumes cmp_imp_equal: "⟦x∈D; y∈D⟧ ⟹ cmp x y = EQUAL ⟹ x = y"
begin
lemma cmp_eq[simp]: "⟦x∈D; y∈D⟧ ⟹ cmp x y = EQUAL ⟷ x = y"
by (auto simp: cmp_imp_equal)
end
abbreviation "eq_linorder ≡ eq_linorder_on UNIV"
lemma dflt_cmp_2inv[simp]:
"dflt_cmp (comp2le cmp) (comp2lt cmp) = cmp"
unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
apply (auto split: comp_res.splits intro!: ext)
done
lemma (in linorder) dflt_cmp_inv2[simp]:
shows
"(comp2le (dflt_cmp (≤) (<)))= (≤)"
"(comp2lt (dflt_cmp (≤) (<)))= (<)"
proof -
show "(comp2lt (dflt_cmp (≤) (<)))= (<)"
unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
apply (auto split: comp_res.splits intro!: ext)
done
show "(comp2le (dflt_cmp (≤) (<))) = (≤)"
unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
apply (auto split: comp_res.splits intro!: ext)
done
qed
lemma eq_linorder_class_conv:
"eq_linorder cmp ⟷ class.linorder (comp2le cmp) (comp2lt cmp)"
proof
assume "eq_linorder cmp"
then interpret eq_linorder_on UNIV cmp .
have "linorder cmp" by unfold_locales
show "class.linorder (comp2le cmp) (comp2lt cmp)"
apply (rule linorder_to_class)
apply fact
by simp
next
assume "class.linorder (comp2le cmp) (comp2lt cmp)"
then interpret linorder "comp2le cmp" "comp2lt cmp" .
from class_to_linorder interpret linorder_on UNIV cmp
by simp
show "eq_linorder cmp"
proof
fix x y
assume "cmp x y = EQUAL"
hence "comp2le cmp x y" "¬comp2lt cmp x y"
by (auto simp: comp2le_def comp2lt_def)
thus "x=y" by simp
qed
qed
lemma (in linorder) class_to_eq_linorder:
"eq_linorder (dflt_cmp (≤) (<))"
proof -
interpret linorder_on UNIV "dflt_cmp (≤) (<)"
by (rule class_to_linorder)
show ?thesis
apply unfold_locales
apply (auto simp: dflt_cmp_def split: if_split_asm)
done
qed
lemma eq_linorder_comp2eq_eq:
assumes "eq_linorder cmp"
shows "comp2eq cmp = (=)"
proof -
interpret eq_linorder_on UNIV cmp by fact
show ?thesis
apply (intro ext)
unfolding comp2eq_def
apply (auto split: comp_res.split dest: refl)
done
qed
lemma restrict_eq_linorder:
assumes "eq_linorder_on D cmp"
assumes S: "D'⊆D"
shows "eq_linorder_on D' cmp"
proof -
interpret eq_linorder_on D cmp by fact
show ?thesis
apply (rule eq_linorder_on.intro)
apply (rule restrict_linorder[where D=D])
apply unfold_locales []
apply fact
apply unfold_locales
using S
apply -
apply (drule (1) rev_subsetD)+
apply auto
done
qed
lemma combine_eq_linorder[intro?]:
assumes A: "eq_linorder_on D1 cmp1"
assumes B: "eq_linorder_on D2 cmp2"
assumes EQ: "D=D1∪D2"
shows "eq_linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
proof -
interpret A: eq_linorder_on D1 cmp1 by fact
interpret B: eq_linorder_on D2 cmp2 by fact
interpret linorder_on "(D1 ∪ D2)" "(cmp_combine D1 cmp1 D2 cmp2)"
apply rule
apply unfold_locales
by simp
show ?thesis
apply (simp only: EQ)
apply unfold_locales
unfolding cmp_combine_def
by (auto split: if_split_asm)
qed
lemma img_eq_linorder[intro?]:
assumes A: "eq_linorder_on (f`D) cmp"
assumes INJ: "inj_on f D"
shows "eq_linorder_on D (cmp_img f cmp)"
proof -
interpret eq_linorder_on "f`D" cmp by fact
interpret L: linorder_on "(D)" "(cmp_img f cmp)"
apply rule
apply unfold_locales
done
show ?thesis
apply unfold_locales
unfolding cmp_img_def
using INJ
apply (auto dest: inj_onD)
done
qed
lemma univ_eq_linorder[intro?]:
shows "eq_linorder univ_cmp"
apply (rule eq_linorder_on.intro)
apply rule
apply unfold_locales
unfolding univ_cmp_def
apply (auto split: if_split_asm)
done
lemma extend_eq_linorder[intro?]:
assumes "eq_linorder_on D cmp"
shows "eq_linorder (cmp_extend D cmp)"
proof -
interpret eq_linorder_on D cmp by fact
show ?thesis
unfolding cmp_extend_def
apply (rule)
apply fact
apply rule
by simp
qed
lemma lex_eq_linorder[intro?]:
assumes "eq_linorder_on D cmp"
shows "eq_linorder_on (lists D) (cmp_lex cmp)"
proof -
interpret eq_linorder_on D cmp by fact
show ?thesis
apply (rule eq_linorder_on.intro)
apply rule
apply unfold_locales
subgoal for l m
apply (induct cmp≡cmp l m rule: cmp_lex.induct)
apply (auto split: comp_res.splits)
done
done
qed
lemma prod_eq_linorder[intro?]:
assumes "eq_linorder_on D1 cmp1"
assumes "eq_linorder_on D2 cmp2"
shows "eq_linorder_on (D1×D2) (cmp_prod cmp1 cmp2)"
proof -
interpret A: eq_linorder_on D1 cmp1 by fact
interpret B: eq_linorder_on D2 cmp2 by fact
show ?thesis
apply (rule eq_linorder_on.intro)
apply rule
apply unfold_locales
apply (auto split: comp_res.splits)
done
qed
lemma set_ord_eq_linorder[intro?]:
"eq_linorder cmp ⟹ eq_linorder (cmp_set cmp)"
unfolding cmp_set_def
apply rule
apply rule
apply (rule restrict_eq_linorder)
apply rule
apply assumption
apply simp
apply (rule linorder.sorted_list_of_set_inj)
apply (subst (asm) eq_linorder_class_conv)
.
lemma map_ord_eq_linorder[intro?]:
"⟦eq_linorder cmpk; eq_linorder cmpv⟧ ⟹ eq_linorder (cmp_map cmpk cmpv)"
unfolding cmp_map_def
apply rule
apply rule
apply (rule restrict_eq_linorder)
apply rule
apply rule
apply assumption
apply assumption
apply simp
apply (rule linorder.sorted_list_of_map_inj)
apply (subst (asm) eq_linorder_class_conv)
.
definition cmp_unit :: "unit ⇒ unit ⇒ comp_res"
where [simp]: "cmp_unit u v ≡ EQUAL"
lemma cmp_unit_eq_linorder:
"eq_linorder cmp_unit"
by unfold_locales simp_all
subsection ‹Parametricity›
lemma param_cmp_extend[param]:
assumes "(cmp,cmp')∈R → R → Id"
assumes "Range R ⊆ D"
shows "(cmp,cmp_extend D cmp') ∈ R → R → Id"
unfolding cmp_extend_def cmp_combine_def[abs_def]
using assms
apply clarsimp
by (blast dest!: fun_relD)
lemma param_cmp_img[param]:
"(cmp_img,cmp_img) ∈ (Ra→Rb) → (Rb→Rb→Rc) → Ra → Ra → Rc"
unfolding cmp_img_def[abs_def]
by parametricity
lemma param_comp_res[param]:
"(LESS,LESS)∈Id"
"(EQUAL,EQUAL)∈Id"
"(GREATER,GREATER)∈Id"
"(case_comp_res,case_comp_res)∈Ra→Ra→Ra→Id→Ra"
by (auto split: comp_res.split)
term cmp_lex
lemma param_cmp_lex[param]:
"(cmp_lex,cmp_lex)∈(Ra→Rb→Id)→⟨Ra⟩list_rel→⟨Rb⟩list_rel→Id"
unfolding cmp_lex_alt[abs_def] cmp_lex'_def
by (parametricity)
term cmp_prod
lemma param_cmp_prod[param]:
"(cmp_prod,cmp_prod)∈
(Ra→Rb→Id)→(Rc→Rd→Id)→⟨Ra,Rc⟩prod_rel→⟨Rb,Rd⟩prod_rel→Id"
unfolding cmp_prod_alt
by (parametricity)
lemma param_cmp_unit[param]:
"(cmp_unit,cmp_unit)∈Id→Id→Id"
by auto
lemma param_comp2eq[param]: "(comp2eq,comp2eq)∈(R→R→Id)→R→R→Id"
unfolding comp2eq_def[abs_def]
by (parametricity)
lemma cmp_combine_paramD:
assumes "(cmp,cmp_combine D1 cmp1 D2 cmp2)∈R→R→Id"
assumes "Range R ⊆ D1"
shows "(cmp,cmp1)∈R→R→Id"
using assms
unfolding cmp_combine_def[abs_def]
apply (intro fun_relI)
apply (drule_tac x=a in fun_relD, assumption)
apply (drule_tac x=aa in fun_relD, assumption)
apply (drule RangeI, drule (1) rev_subsetD)
apply (drule RangeI, drule (1) rev_subsetD)
apply simp
done
lemma cmp_extend_paramD:
assumes "(cmp,cmp_extend D cmp')∈R→R→Id"
assumes "Range R ⊆ D"
shows "(cmp,cmp')∈R→R→Id"
using assms
unfolding cmp_extend_def
apply (rule cmp_combine_paramD)
done
subsection ‹Tuning of Generated Implementation›
lemma [autoref_post_simps]: "comp2eq (dflt_cmp (≤) ((<)::_::linorder⇒_)) = (=)"
by (simp add: class_to_eq_linorder eq_linorder_comp2eq_eq)
end
Theory GenCF_Gen_Chapter
theory GenCF_Gen_Chapter imports Main begin
text_raw ‹\isasection{Generic Algorithms}›
end
Theory Gen_Set
section ‹\isaheader{Generic Set Algorithms}›
theory Gen_Set
imports "../Intf/Intf_Set" "../../Iterator/Iterator"
begin
lemma foldli_union: "det_fold_set X (λ_. True) insert a ((∪) a)"
proof (rule, goal_cases)
case (1 l) thus ?case
by (induct l arbitrary: a) auto
qed
definition gen_union
:: "_ ⇒ ('k ⇒ 's2 ⇒ 's2)
⇒ 's1 ⇒ 's2 ⇒ 's2"
where
"gen_union it ins A B ≡ it A (λ_. True) ins B"
lemma gen_union[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes INS: "GEN_OP ins Set.insert (Rk→⟨Rk⟩Rs2→⟨Rk⟩Rs2)"
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
shows "(gen_union (λx. foldli (tsl x)) ins,(∪))
∈ (⟨Rk⟩Rs1) → (⟨Rk⟩Rs2) → (⟨Rk⟩Rs2)"
apply (intro fun_relI)
apply (subst Un_commute)
unfolding gen_union_def
apply (rule det_fold_set[OF
foldli_union IT[unfolded autoref_tag_defs]])
using INS
unfolding autoref_tag_defs
apply (parametricity)+
done
lemma foldli_inter: "det_fold_set X (λ_. True)
(λx s. if x∈a then insert x s else s) {} (λs. s∩a)"
(is "det_fold_set _ _ ?f _ _")
proof -
{
fix l s0
have "foldli l (λ_. True)
(λx s. if x∈a then insert x s else s) s0 = s0 ∪ (set l ∩ a)"
by (induct l arbitrary: s0) auto
}
from this[of _ "{}"] show ?thesis apply - by rule simp
qed
definition gen_inter :: "_ ⇒
('k ⇒ 's2 ⇒ bool) ⇒ _"
where "gen_inter it1 memb2 ins3 empty3 s1 s2
≡ it1 s1 (λ_. True)
(λx s. if memb2 x s2 then ins3 x s else s) empty3"
lemma gen_inter[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
assumes MEMB:
"GEN_OP memb2 (∈) (Rk → ⟨Rk⟩Rs2 → Id)"
assumes INS:
"GEN_OP ins3 Set.insert (Rk→⟨Rk⟩Rs3→⟨Rk⟩Rs3)"
assumes EMPTY:
"GEN_OP empty3 {} (⟨Rk⟩Rs3)"
shows "(gen_inter (λx. foldli (tsl x)) memb2 ins3 empty3,(∩))
∈ (⟨Rk⟩Rs1) → (⟨Rk⟩Rs2) → (⟨Rk⟩Rs3)"
apply (intro fun_relI)
unfolding gen_inter_def
apply (rule det_fold_set[OF foldli_inter IT[unfolded autoref_tag_defs]])
using MEMB INS EMPTY
unfolding autoref_tag_defs
apply (parametricity)+
done
lemma foldli_diff:
"det_fold_set X (λ_. True) (λx s. op_set_delete x s) s ((-) s)"
proof (rule, goal_cases)
case (1 l) thus ?case
by (induct l arbitrary: s) auto
qed
definition gen_diff :: "('k⇒'s1⇒'s1) ⇒ _ ⇒ 's2 ⇒ _ "
where "gen_diff del1 it2 s1 s2
≡ it2 s2 (λ_. True) (λx s. del1 x s) s1"
lemma gen_diff[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes DEL:
"GEN_OP del1 op_set_delete (Rk → ⟨Rk⟩Rs1 → ⟨Rk⟩Rs1)"
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs2 it2)"
shows "(gen_diff del1 (λx. foldli (it2 x)),(-))
∈ (⟨Rk⟩Rs1) → (⟨Rk⟩Rs2) → (⟨Rk⟩Rs1)"
apply (intro fun_relI)
unfolding gen_diff_def
apply (rule det_fold_set[OF foldli_diff IT[unfolded autoref_tag_defs]])
using DEL
unfolding autoref_tag_defs
apply (parametricity)+
done
lemma foldli_ball_aux:
"foldli l (λx. x) (λx _. P x) b ⟷ b ∧ Ball (set l) P"
by (induct l arbitrary: b) auto
lemma foldli_ball: "det_fold_set X (λx. x) (λx _. P x) True (λs. Ball s P)"
apply rule using foldli_ball_aux[where b=True] by simp
definition gen_ball :: "_ ⇒ 's ⇒ ('k ⇒ bool) ⇒ _ "
where "gen_ball it s P ≡ it s (λx. x) (λx _. P x) True"
lemma gen_ball[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
shows "(gen_ball (λx. foldli (it x)),Ball) ∈ ⟨Rk⟩Rs → (Rk→Id) → Id"
apply (intro fun_relI)
unfolding gen_ball_def
apply (rule det_fold_set[OF foldli_ball IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma foldli_bex_aux: "foldli l (λx. ¬x) (λx _. P x) b ⟷ b ∨ Bex (set l) P"
by (induct l arbitrary: b) auto
lemma foldli_bex: "det_fold_set X (λx. ¬x) (λx _. P x) False (λs. Bex s P)"
apply rule using foldli_bex_aux[where b=False] by simp
definition gen_bex :: "_ ⇒ 's ⇒ ('k ⇒ bool) ⇒ _ "
where "gen_bex it s P ≡ it s (λx. ¬x) (λx _. P x) False"
lemma gen_bex[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
shows "(gen_bex (λx. foldli (it x)),Bex) ∈ ⟨Rk⟩Rs → (Rk→Id) → Id"
apply (intro fun_relI)
unfolding gen_bex_def
apply (rule det_fold_set[OF foldli_bex IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma ball_subseteq:
"(Ball s1 (λx. x∈s2)) ⟷ s1 ⊆ s2"
by blast
definition gen_subseteq
:: "('s1 ⇒ ('k ⇒ bool) ⇒ bool) ⇒ ('k ⇒ 's2 ⇒ bool) ⇒ _"
where "gen_subseteq ball1 mem2 s1 s2 ≡ ball1 s1 (λx. mem2 x s2)"
lemma gen_subseteq[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes "GEN_OP ball1 Ball (⟨Rk⟩Rs1 → (Rk→Id) → Id)"
assumes "GEN_OP mem2 (∈) (Rk → ⟨Rk⟩Rs2 → Id)"
shows "(gen_subseteq ball1 mem2,(⊆)) ∈ ⟨Rk⟩Rs1 → ⟨Rk⟩Rs2 → Id"
apply (intro fun_relI)
unfolding gen_subseteq_def using assms
unfolding autoref_tag_defs
apply -
apply (subst ball_subseteq[symmetric])
apply parametricity
done
definition "gen_equal ss1 ss2 s1 s2 ≡ ss1 s1 s2 ∧ ss2 s2 s1"
lemma gen_equal[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes "GEN_OP ss1 (⊆) (⟨Rk⟩Rs1 → ⟨Rk⟩Rs2 → Id)"
assumes "GEN_OP ss2 (⊆) (⟨Rk⟩Rs2 → ⟨Rk⟩Rs1 → Id)"
shows "(gen_equal ss1 ss2, (=)) ∈ ⟨Rk⟩Rs1 → ⟨Rk⟩Rs2 → Id"
apply (intro fun_relI)
unfolding gen_equal_def using assms
unfolding autoref_tag_defs
apply -
apply (subst set_eq_subset)
apply (parametricity)
done
lemma foldli_card_aux: "distinct l ⟹ foldli l (λ_. True)
(λ_ n. Suc n) n = n + card (set l)"
apply (induct l arbitrary: n)
apply auto
done
lemma foldli_card: "det_fold_set X (λ_. True) (λ_ n. Suc n) 0 card"
apply rule using foldli_card_aux[where n=0] by simp
definition gen_card where
"gen_card it s ≡ it s (λx. True) (λ_ n. Suc n) 0"
lemma gen_card[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
shows "(gen_card (λx. foldli (it x)),card) ∈ ⟨Rk⟩Rs → Id"
apply (intro fun_relI)
unfolding gen_card_def
apply (rule det_fold_set[OF foldli_card IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma fold_set: "fold Set.insert l s = s ∪ set l"
by (induct l arbitrary: s) auto
definition gen_set :: "'s ⇒ ('k ⇒ 's ⇒ 's) ⇒ _" where
"gen_set emp ins l = fold ins l emp"
lemma gen_set[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes EMPTY:
"GEN_OP emp {} (⟨Rk⟩Rs)"
assumes INS:
"GEN_OP ins Set.insert (Rk→⟨Rk⟩Rs→⟨Rk⟩Rs)"
shows "(gen_set emp ins,set)∈⟨Rk⟩list_rel→⟨Rk⟩Rs"
apply (intro fun_relI)
unfolding gen_set_def using assms
unfolding autoref_tag_defs
apply -
apply (subst fold_set[where s="{}",simplified,symmetric])
apply parametricity
done
lemma ball_isEmpty: "op_set_isEmpty s = (∀x∈s. False)"
by auto
definition gen_isEmpty :: "('s ⇒ ('k ⇒ bool) ⇒ bool) ⇒ 's ⇒ bool" where
"gen_isEmpty ball s ≡ ball s (λ_. False)"
lemma gen_isEmpty[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes "GEN_OP ball Ball (⟨Rk⟩Rs → (Rk→Id) → Id)"
shows "(gen_isEmpty ball,op_set_isEmpty) ∈ ⟨Rk⟩Rs → Id"
apply (intro fun_relI)
unfolding gen_isEmpty_def using assms
unfolding autoref_tag_defs
apply -
apply (subst ball_isEmpty)
apply parametricity
done
lemma foldli_size_abort_aux:
"⟦n0≤m; distinct l⟧ ⟹
foldli l (λn. n<m) (λ_ n. Suc n) n0 = min m (n0 + card (set l))"
apply (induct l arbitrary: n0)
apply auto
done
lemma foldli_size_abort: "
det_fold_set X (λn. n<m) (λ_ n. Suc n) 0 (op_set_size_abort m)"
apply rule
using foldli_size_abort_aux[where ?n0.0=0]
by simp
definition gen_size_abort where
"gen_size_abort it m s ≡ it s (λn. n<m) (λ_ n. Suc n) 0"
lemma gen_size_abort[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
shows "(gen_size_abort (λx. foldli (it x)),op_set_size_abort)
∈ Id → ⟨Rk⟩Rs → Id"
apply (intro fun_relI)
unfolding gen_size_abort_def
apply (rule det_fold_set[OF foldli_size_abort IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma size_abort_isSng: "op_set_isSng s ⟷ op_set_size_abort 2 s = 1"
by auto
definition gen_isSng :: "(nat ⇒ 's ⇒ nat) ⇒ _" where
"gen_isSng sizea s ≡ sizea 2 s = 1"
lemma gen_isSng[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes "GEN_OP sizea op_set_size_abort (Id → (⟨Rk⟩Rs) → Id)"
shows "(gen_isSng sizea,op_set_isSng) ∈ ⟨Rk⟩Rs → Id"
apply (intro fun_relI)
unfolding gen_isSng_def using assms
unfolding autoref_tag_defs
apply -
apply (subst size_abort_isSng)
apply parametricity
done
lemma foldli_disjoint_aux:
"foldli l1 (λx. x) (λx _. ¬x∈s2) b ⟷ b ∧ op_set_disjoint (set l1) s2"
by (induct l1 arbitrary: b) auto
lemma foldli_disjoint:
"det_fold_set X (λx. x) (λx _. ¬x∈s2) True (λs1. op_set_disjoint s1 s2)"
apply rule using foldli_disjoint_aux[where b=True] by simp
definition gen_disjoint
:: "_ ⇒ ('k⇒'s2⇒bool) ⇒ _"
where "gen_disjoint it1 mem2 s1 s2
≡ it1 s1 (λx. x) (λx _. ¬mem2 x s2) True"
lemma gen_disjoint[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
assumes MEM: "GEN_OP mem2 (∈) (Rk → ⟨Rk⟩Rs2 → Id)"
shows "(gen_disjoint (λx. foldli (it1 x)) mem2,op_set_disjoint)
∈ ⟨Rk⟩Rs1 → ⟨Rk⟩Rs2 → Id"
apply (intro fun_relI)
unfolding gen_disjoint_def
apply (rule det_fold_set[OF foldli_disjoint IT[unfolded autoref_tag_defs]])
using MEM unfolding autoref_tag_defs
apply (parametricity)+
done
lemma foldli_filter_aux:
"foldli l (λ_. True) (λx s. if P x then insert x s else s) s0
= s0 ∪ op_set_filter P (set l)"
by (induct l arbitrary: s0) auto
lemma foldli_filter:
"det_fold_set X (λ_. True) (λx s. if P x then insert x s else s) {}
(op_set_filter P)"
apply rule using foldli_filter_aux[where ?s0.0="{}"] by simp
definition gen_filter
where "gen_filter it1 emp2 ins2 P s1 ≡
it1 s1 (λ_. True) (λx s. if P x then ins2 x s else s) emp2"
lemma gen_filter[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
assumes INS:
"GEN_OP ins2 Set.insert (Rk→⟨Rk⟩Rs2→⟨Rk⟩Rs2)"
assumes EMPTY:
"GEN_OP empty2 {} (⟨Rk⟩Rs2)"
shows "(gen_filter (λx. foldli (it1 x)) empty2 ins2,op_set_filter)
∈ (Rk→Id) → (⟨Rk⟩Rs1) → (⟨Rk⟩Rs2)"
apply (intro fun_relI)
unfolding gen_filter_def
apply (rule det_fold_set[OF foldli_filter IT[unfolded autoref_tag_defs]])
using INS EMPTY unfolding autoref_tag_defs
apply (parametricity)+
done
lemma foldli_image_aux:
"foldli l (λ_. True) (λx s. insert (f x) s) s0
= s0 ∪ f`(set l)"
by (induct l arbitrary: s0) auto
lemma foldli_image:
"det_fold_set X (λ_. True) (λx s. insert (f x) s) {}
((`) f)"
apply rule using foldli_image_aux[where ?s0.0="{}"] by simp
definition gen_image
where "gen_image it1 emp2 ins2 f s1 ≡
it1 s1 (λ_. True) (λx s. ins2 (f x) s) emp2"
lemma gen_image[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
assumes INS:
"GEN_OP ins2 Set.insert (Rk'→⟨Rk'⟩Rs2→⟨Rk'⟩Rs2)"
assumes EMPTY:
"GEN_OP empty2 {} (⟨Rk'⟩Rs2)"
shows "(gen_image (λx. foldli (it1 x)) empty2 ins2,(`))
∈ (Rk→Rk') → (⟨Rk⟩Rs1) → (⟨Rk'⟩Rs2)"
apply (intro fun_relI)
unfolding gen_image_def
apply (rule det_fold_set[OF foldli_image IT[unfolded autoref_tag_defs]])
using INS EMPTY unfolding autoref_tag_defs
apply (parametricity)+
done
lemma foldli_pick:
assumes "l≠[]"
obtains x where "x∈set l"
and "(foldli l (case_option True (λ_. False)) (λx _. Some x) None) = Some x"
using assms by (cases l) auto
definition gen_pick where
"gen_pick it s ≡
(the (it s (case_option True (λ_. False)) (λx _. Some x) None))"
context begin interpretation autoref_syn .
lemma gen_pick[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
assumes NE: "SIDE_PRECOND (s'≠{})"
assumes SREF: "(s,s')∈⟨Rk⟩Rs"
shows "(RETURN (gen_pick (λx. foldli (it x)) s),
(OP op_set_pick ::: ⟨Rk⟩Rs→⟨Rk⟩nres_rel)$s')∈⟨Rk⟩nres_rel"
proof -
obtain tsl' where
[param]: "(it s,tsl') ∈ ⟨Rk⟩list_rel"
and IT': "RETURN tsl' ≤ it_to_sorted_list (λ_ _. True) s'"
using IT[unfolded autoref_tag_defs is_set_to_list_def] SREF
by (rule is_set_to_sorted_listE)
from IT' NE have "tsl'≠[]" and [simp]: "s'=set tsl'"
unfolding it_to_sorted_list_def by simp_all
then obtain x where "x∈s'" and
"(foldli tsl' (case_option True (λ_. False)) (λx _. Some x) None) = Some x"
(is "?fld = _")
by (blast elim: foldli_pick)
moreover
have "(RETURN (gen_pick (λx. foldli (it x)) s), RETURN (the ?fld))
∈ ⟨Rk⟩nres_rel"
unfolding gen_pick_def
apply (parametricity add: the_paramR)
using ‹?fld = Some x›
by simp
ultimately show ?thesis
unfolding autoref_tag_defs
apply -
apply (drule nres_relD)
apply (rule nres_relI)
apply (erule ref_two_step)
by simp
qed
end
definition gen_Sigma
where "gen_Sigma it1 it2 empX insX s1 f2 ≡
it1 s1 (λ_. True) (λx s.
it2 (f2 x) (λ_. True) (λy s. insX (x,y) s) s
) empX
"
lemma foldli_Sigma_aux:
fixes s :: "'s1_impl" and s':: "'k set"
fixes f :: "'k_impl ⇒ 's2_impl" and f':: "'k ⇒ 'l set"
fixes s0 :: "'kl_impl" and s0' :: "('k×'l) set"
assumes IT1: "is_set_to_list Rk Rs1 it1"
assumes IT2: "is_set_to_list Rl Rs2 it2"
assumes INS:
"(insX, Set.insert) ∈
(⟨Rk,Rl⟩prod_rel→⟨⟨Rk,Rl⟩prod_rel⟩Rs3→⟨⟨Rk,Rl⟩prod_rel⟩Rs3)"
assumes S0R: "(s0, s0') ∈ ⟨⟨Rk,Rl⟩prod_rel⟩Rs3"
assumes SR: "(s, s') ∈ ⟨Rk⟩Rs1"
assumes FR: "(f, f') ∈ Rk → ⟨Rl⟩Rs2"
shows "(foldli (it1 s) (λ_. True) (λx s.
foldli (it2 (f x)) (λ_. True) (λy s. insX (x,y) s) s
) s0,s0' ∪ Sigma s' f')
∈ ⟨⟨Rk,Rl⟩prod_rel⟩Rs3"
proof -
have S: "⋀x s f. Sigma (insert x s) f = ({x}×f x) ∪ Sigma s f"
by auto
obtain l' where
IT1L: "(it1 s,l')∈⟨Rk⟩list_rel"
and SL: "s' = set l'"
apply (rule
is_set_to_sorted_listE[OF IT1[unfolded is_set_to_list_def] SR])
by (auto simp: it_to_sorted_list_def)
show ?thesis
unfolding SL
using IT1L S0R
proof (induct arbitrary: s0 s0' rule: list_rel_induct)
case Nil thus ?case by simp
next
case (Cons x x' l l')
obtain l2' where
IT2L: "(it2 (f x),l2')∈⟨Rl⟩list_rel"
and FXL: "f' x' = set l2'"
apply (rule
is_set_to_sorted_listE[
OF IT2[unfolded is_set_to_list_def], of "f x" "f' x'"
])
apply (parametricity add: Cons.hyps(1) FR)
by (auto simp: it_to_sorted_list_def)
have "(foldli (it2 (f x)) (λ_. True) (λy. insX (x, y)) s0,
s0' ∪ {x'}×f' x') ∈ ⟨⟨Rk,Rl⟩prod_rel⟩Rs3"
unfolding FXL
using IT2L ‹(s0, s0') ∈ ⟨⟨Rk, Rl⟩prod_rel⟩Rs3›
apply (induct arbitrary: s0 s0' rule: list_rel_induct)
apply simp
apply simp
apply (subst Un_insert_left[symmetric])
apply (rprems)
apply (parametricity add: INS ‹(x,x')∈Rk›)
done
show ?case
apply simp
apply (subst S)
apply (subst Un_assoc[symmetric])
apply (rule Cons.hyps)
apply fact
done
qed
qed
lemma gen_Sigma[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT1: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
assumes IT2: "SIDE_GEN_ALGO (is_set_to_list Rl Rs2 it2)"
assumes EMPTY:
"GEN_OP empX {} (⟨⟨Rk,Rl⟩prod_rel⟩Rs3)"
assumes INS:
"GEN_OP insX Set.insert
(⟨Rk,Rl⟩prod_rel→⟨⟨Rk,Rl⟩prod_rel⟩Rs3→⟨⟨Rk,Rl⟩prod_rel⟩Rs3)"
shows "(gen_Sigma (λx. foldli (it1 x)) (λx. foldli (it2 x)) empX insX,Sigma)
∈ (⟨Rk⟩Rs1) → (Rk → ⟨Rl⟩Rs2) → ⟨⟨Rk,Rl⟩prod_rel⟩Rs3"
apply (intro fun_relI)
unfolding gen_Sigma_def
using foldli_Sigma_aux[OF
IT1[unfolded autoref_tag_defs]
IT2[unfolded autoref_tag_defs]
INS[unfolded autoref_tag_defs]
EMPTY[unfolded autoref_tag_defs]
]
by simp
lemma gen_cart:
assumes PRIO_TAG_GEN_ALGO
assumes [param]: "(sigma, Sigma) ∈ (⟨Rx⟩Rsx → (Rx → ⟨Ry⟩Rsy) → ⟨Rx ×⇩r Ry⟩Rsp)"
shows "(λx y. sigma x (λ_. y), op_set_cart) ∈ ⟨Rx⟩Rsx → ⟨Ry⟩Rsy → ⟨Rx ×⇩r Ry⟩Rsp"
unfolding op_set_cart_def[abs_def]
by parametricity
lemmas [autoref_rules] = gen_cart[OF _ GEN_OP_D]
context begin interpretation autoref_syn .
lemma op_set_to_sorted_list_autoref[autoref_rules]:
assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
shows "(λsi. RETURN (tsl si), OP (op_set_to_sorted_list ordR))
∈ ⟨Rk⟩Rs → ⟨⟨Rk⟩list_rel⟩nres_rel"
using assms
apply (intro fun_relI nres_relI)
apply simp
apply (rule RETURN_SPEC_refine)
apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
done
lemma op_set_to_list_autoref[autoref_rules]:
assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
shows "(λsi. RETURN (tsl si), op_set_to_list)
∈ ⟨Rk⟩Rs → ⟨⟨Rk⟩list_rel⟩nres_rel"
using assms
apply (intro fun_relI nres_relI)
apply simp
apply (rule RETURN_SPEC_refine)
apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
done
end
lemma foldli_Union: "det_fold_set X (λ_. True) (∪) {} Union"
proof (rule, goal_cases)
case (1 l)
have "∀a. foldli l (λ_. True) (∪) a = a ∪ ⋃(set l)"
by (induct l) auto
thus ?case by auto
qed
definition gen_Union
:: "_ ⇒ 's3 ⇒ ('s2 ⇒ 's3 ⇒ 's3)
⇒ 's1 ⇒ 's3"
where
"gen_Union it emp un X ≡ it X (λ_. True) un emp"
lemma gen_Union[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes EMP: "GEN_OP emp {} (⟨Rk⟩Rs3)"
assumes UN: "GEN_OP un (∪) (⟨Rk⟩Rs2→⟨Rk⟩Rs3→⟨Rk⟩Rs3)"
assumes IT: "SIDE_GEN_ALGO (is_set_to_list (⟨Rk⟩Rs2) Rs1 tsl)"
shows "(gen_Union (λx. foldli (tsl x)) emp un,Union) ∈ ⟨⟨Rk⟩Rs2⟩Rs1 → ⟨Rk⟩Rs3"
apply (intro fun_relI)
unfolding gen_Union_def
apply (rule det_fold_set[OF
foldli_Union IT[unfolded autoref_tag_defs]])
using EMP UN
unfolding autoref_tag_defs
apply (parametricity)+
done
definition "atLeastLessThan_impl a b ≡ do {
(_,r) ← WHILET (λ(i,r). i<b) (λ(i,r). RETURN (i+1, insert i r)) (a,{});
RETURN r
}"
lemma atLeastLessThan_impl_correct:
"atLeastLessThan_impl a b ≤ SPEC (λr. r = {a..<b::nat})"
unfolding atLeastLessThan_impl_def
apply (refine_rcg refine_vcg WHILET_rule[where
I = "λ(i,r). r = {a..<i} ∧ a≤i ∧ ((a<b ⟶ i≤b) ∧ (¬a<b ⟶ i=a))"
and R = "measure (λ(i,_). b - i)"
])
by auto
schematic_goal atLeastLessThan_code_aux:
notes [autoref_rules] = IdI[of a] IdI[of b]
assumes [autoref_rules]: "(emp,{})∈Rs"
assumes [autoref_rules]: "(ins,insert)∈nat_rel → Rs → Rs"
shows "(?c, atLeastLessThan_impl)
∈ nat_rel → nat_rel → ⟨Rs⟩nres_rel"
unfolding atLeastLessThan_impl_def[abs_def]
apply (autoref (keep_goal))
done
concrete_definition atLeastLessThan_code uses atLeastLessThan_code_aux
schematic_goal atLeastLessThan_tr_aux:
"RETURN ?c ≤ atLeastLessThan_code emp ins a b"
unfolding atLeastLessThan_code_def
by (refine_transfer (post))
concrete_definition atLeastLessThan_tr
for emp ins a b uses atLeastLessThan_tr_aux
lemma atLeastLessThan_gen[autoref_rules]:
assumes "PRIO_TAG_GEN_ALGO"
assumes "GEN_OP emp {} Rs"
assumes "GEN_OP ins insert (nat_rel → Rs → Rs)"
shows "(atLeastLessThan_tr emp ins, atLeastLessThan)
∈ nat_rel → nat_rel → Rs"
proof (intro fun_relI, simp)
fix a b
from assms have GEN:
"(emp,{})∈Rs" "(ins,insert)∈nat_rel → Rs → Rs"
by auto
note atLeastLessThan_tr.refine[of emp ins a b]
also note
atLeastLessThan_code.refine[OF GEN,param_fo, OF IdI IdI, THEN nres_relD]
also note atLeastLessThan_impl_correct
finally show "(atLeastLessThan_tr emp ins a b, {a..<b}) ∈ Rs"
by (auto simp: pw_le_iff refine_pw_simps)
qed
end
Theory Gen_Map
section ‹\isaheader{Generic Map Algorithms}›
theory Gen_Map
imports "../Intf/Intf_Map" "../../Iterator/Iterator"
begin
lemma map_to_set_distinct_conv:
assumes "distinct tsl'" and "map_to_set m' = set tsl'"
shows "distinct (map fst tsl')"
apply (rule ccontr)
apply (drule not_distinct_decomp)
using assms
apply (clarsimp elim!: map_eq_appendE)
by (metis (hide_lams, no_types) insert_iff map_to_set_inj)
lemma foldli_add: "det_fold_map X
(λ_. True) (λ(k,v) m. op_map_update k v m) m ((++) m)"
proof (rule, goal_cases)
case (1 l) thus ?case
apply (induct l arbitrary: m)
apply (auto simp: map_of_distinct_upd[symmetric])
done
qed
definition gen_add
:: "('s2 ⇒ _) ⇒ ('k ⇒ 'v ⇒ 's1 ⇒ 's1) ⇒ 's1 ⇒ 's2 ⇒ 's1"
where
"gen_add it upd A B ≡ it B (λ_. True) (λ(k,v) m. upd k v m) A"
lemma gen_add[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes UPD: "GEN_OP ins op_map_update (Rk→Rv→⟨Rk,Rv⟩Rs1→⟨Rk,Rv⟩Rs1)"
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs2 tsl)"
shows "(gen_add (foldli o tsl) ins,(++))
∈ (⟨Rk,Rv⟩Rs1) → (⟨Rk,Rv⟩Rs2) → (⟨Rk,Rv⟩Rs1)"
apply (intro fun_relI)
unfolding gen_add_def comp_def
apply (rule det_fold_map[OF foldli_add IT[unfolded autoref_tag_defs]])
apply (parametricity add: UPD[unfolded autoref_tag_defs])+
done
lemma foldli_restrict: "det_fold_map X (λ_. True)
(λ(k,v) m. if P (k,v) then op_map_update k v m else m) Map.empty
(op_map_restrict P )" (is "det_fold_map _ _ ?f _ _")
proof -
{
fix l m
have "distinct (map fst l) ⟹
foldli l (λ_. True) ?f m = m ++ op_map_restrict P (map_of l)"
proof (induction l arbitrary: m)
case Nil thus ?case by simp
next
case (Cons kv l)
obtain k v where [simp]: "kv = (k,v)" by fastforce
from Cons.prems have
DL: "distinct (map fst l)" and KNI: "k ∉ set (map fst l)"
by auto
show ?case proof (cases "P (k,v)")
case [simp]: True
have "foldli (kv#l) (λ_. True) ?f m = foldli l (λ_. True) ?f (m(k↦v))"
by simp
also from Cons.IH[OF DL] have
"… = m(k↦v) ++ op_map_restrict P (map_of l)" .
also have "… = m ++ op_map_restrict P (map_of (kv#l))"
using KNI
by (auto
split: option.splits
intro!: ext
simp: Map.restrict_map_def Map.map_add_def
simp: map_of_eq_None_iff[symmetric])
finally show ?thesis .
next
case [simp]: False
have "foldli (kv#l) (λ_. True) ?f m = foldli l (λ_. True) ?f m"
by simp
also from Cons.IH[OF DL] have
"… = m ++ op_map_restrict P (map_of l)" .
also have "… = m ++ op_map_restrict P (map_of (kv#l))"
using KNI
by (auto
intro!: ext
simp: Map.restrict_map_def Map.map_add_def
simp: map_of_eq_None_iff[symmetric]
)
finally show ?thesis .
qed
qed
}
from this[of _ Map.empty] show ?thesis
by (auto intro!: det_fold_mapI)
qed
definition gen_restrict :: "('s1 ⇒ _) ⇒ _"
where "gen_restrict it upd emp P m
≡ it m (λ_. True) (λ(k,v) m. if P (k,v) then upd k v m else m) emp"
lemma gen_restrict[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs1 tsl)"
assumes INS:
"GEN_OP upd op_map_update (Rk→Rv→⟨Rk,Rv⟩Rs2→⟨Rk,Rv⟩Rs2)"
assumes EMPTY:
"GEN_OP emp Map.empty (⟨Rk,Rv⟩Rs2)"
shows "(gen_restrict (foldli o tsl) upd emp,op_map_restrict)
∈ (⟨Rk,Rv⟩prod_rel → Id) → (⟨Rk,Rv⟩Rs1) → (⟨Rk,Rv⟩Rs2)"
apply (intro fun_relI)
unfolding gen_restrict_def comp_def
apply (rule det_fold_map[OF foldli_restrict IT[unfolded autoref_tag_defs]])
using INS EMPTY unfolding autoref_tag_defs
apply (parametricity)+
done
lemma fold_map_of:
"fold (λ(k,v) s. op_map_update k v s) (rev l) Map.empty = map_of l"
proof -
{
fix m
have "fold (λ(k,v) s. s(k↦v)) (rev l) m = m ++ map_of l"
apply (induct l arbitrary: m)
apply auto
done
} thus ?thesis by simp
qed
definition gen_map_of :: "'m ⇒ ('k⇒'v⇒'m⇒'m) ⇒ _" where
"gen_map_of emp upd l ≡ fold (λ(k,v) s. upd k v s) (rev l) emp"
lemma gen_map_of[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes UPD: "GEN_OP upd op_map_update (Rk→Rv→⟨Rk,Rv⟩Rm→⟨Rk,Rv⟩Rm)"
assumes EMPTY: "GEN_OP emp Map.empty (⟨Rk,Rv⟩Rm)"
shows "(gen_map_of emp upd,map_of) ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨Rk,Rv⟩Rm"
using assms
apply (intro fun_relI)
unfolding gen_map_of_def[abs_def]
unfolding autoref_tag_defs
apply (subst fold_map_of[symmetric])
apply parametricity
done
lemma foldli_ball_aux:
"distinct (map fst l) ⟹ foldli l (λx. x) (λx _. P x) b
⟷ b ∧ op_map_ball (map_of l) P"
apply (induct l arbitrary: b)
apply simp
apply (force simp: map_to_set_map_of image_def)
done
lemma foldli_ball:
"det_fold_map X (λx. x) (λx _. P x) True (λm. op_map_ball m P)"
apply rule
using foldli_ball_aux[where b=True] by auto
definition gen_ball :: "('m ⇒ _) ⇒ _" where
"gen_ball it m P ≡ it m (λx. x) (λx _. P x) True"
lemma gen_ball[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
shows "(gen_ball (foldli o tsl),op_map_ball)
∈ ⟨Rk,Rv⟩Rm → (⟨Rk,Rv⟩prod_rel → Id) → Id"
apply (intro fun_relI)
unfolding gen_ball_def comp_def
apply (rule det_fold_map[OF foldli_ball IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma foldli_bex_aux:
"distinct (map fst l) ⟹ foldli l (λx. ¬x) (λx _. P x) b
⟷ b ∨ op_map_bex (map_of l) P"
apply (induct l arbitrary: b)
apply simp
apply (force simp: map_to_set_map_of image_def)
done
lemma foldli_bex:
"det_fold_map X (λx. ¬x) (λx _. P x) False (λm. op_map_bex m P)"
apply rule
using foldli_bex_aux[where b=False] by auto
definition gen_bex :: "('m ⇒ _) ⇒ _" where
"gen_bex it m P ≡ it m (λx. ¬x) (λx _. P x) False"
lemma gen_bex[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
shows "(gen_bex (foldli o tsl),op_map_bex)
∈ ⟨Rk,Rv⟩Rm → (⟨Rk,Rv⟩prod_rel → Id) → Id"
apply (intro fun_relI)
unfolding gen_bex_def comp_def
apply (rule det_fold_map[OF foldli_bex IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma ball_isEmpty: "op_map_isEmpty m = op_map_ball m (λ_. False)"
apply (auto intro!: ext)
by (metis map_to_set_simps(7) option.exhaust)
definition "gen_isEmpty ball m ≡ ball m (λ_. False)"
lemma gen_isEmpty[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes BALL:
"GEN_OP ball op_map_ball (⟨Rk,Rv⟩Rm→(⟨Rk,Rv⟩prod_rel→Id) → Id)"
shows "(gen_isEmpty ball,op_map_isEmpty)
∈ ⟨Rk,Rv⟩Rm → Id"
apply (intro fun_relI)
unfolding gen_isEmpty_def using assms
unfolding autoref_tag_defs
apply -
apply (subst ball_isEmpty)
apply parametricity+
done
lemma foldli_size_aux: "distinct (map fst l)
⟹ foldli l (λ_. True) (λ_ n. Suc n) n = n + op_map_size (map_of l)"
apply (induct l arbitrary: n)
apply (auto simp: dom_map_of_conv_image_fst)
done
lemma foldli_size: "det_fold_map X (λ_. True) (λ_ n. Suc n) 0 op_map_size"
apply rule
using foldli_size_aux[where n=0] by simp
definition gen_size :: "('m ⇒ _) ⇒ _"
where "gen_size it m ≡ it m (λ_. True) (λ_ n. Suc n) 0"
lemma gen_size[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
shows "(gen_size (foldli o tsl),op_map_size) ∈ ⟨Rk,Rv⟩Rm → Id"
apply (intro fun_relI)
unfolding gen_size_def comp_def
apply (rule det_fold_map[OF foldli_size IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma foldli_size_abort_aux:
"⟦n0≤m; distinct (map fst l)⟧ ⟹
foldli l (λn. n<m) (λ_ n. Suc n) n0 = min m (n0 + card (dom (map_of l)))"
apply (induct l arbitrary: n0)
apply (auto simp: dom_map_of_conv_image_fst)
done
lemma foldli_size_abort:
"det_fold_map X (λn. n<m) (λ_ n. Suc n) 0 (op_map_size_abort m)"
apply rule
using foldli_size_abort_aux[where ?n0.0=0]
by simp
definition gen_size_abort :: "('s ⇒ _) ⇒ _" where
"gen_size_abort it m s ≡ it s (λn. n<m) (λ_ n. Suc n) 0"
lemma gen_size_abort[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
shows "(gen_size_abort (foldli o tsl),op_map_size_abort)
∈ Id → ⟨Rk,Rv⟩Rm → Id"
apply (intro fun_relI)
unfolding gen_size_abort_def comp_def
apply (rule det_fold_map[OF foldli_size_abort
IT[unfolded autoref_tag_defs]])
apply (parametricity)+
done
lemma size_abort_isSng: "op_map_isSng s ⟷ op_map_size_abort 2 s = 1"
by (auto simp: dom_eq_singleton_conv min_def dest!: card_eq_SucD)
definition gen_isSng :: "(nat ⇒ 's ⇒ nat) ⇒ _" where
"gen_isSng sizea s ≡ sizea 2 s = 1"
lemma gen_isSng[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes "GEN_OP sizea op_map_size_abort (Id → (⟨Rk,Rv⟩Rm) → Id)"
shows "(gen_isSng sizea,op_map_isSng)
∈ ⟨Rk,Rv⟩Rm → Id"
apply (intro fun_relI)
unfolding gen_isSng_def using assms
unfolding autoref_tag_defs
apply -
apply (subst size_abort_isSng)
apply parametricity
done
lemma foldli_pick:
assumes "l≠[]"
obtains k v where "(k,v)∈set l"
and "(foldli l (case_option True (λ_. False)) (λx _. Some x) None)
= Some (k,v)"
using assms by (cases l) auto
definition gen_pick where
"gen_pick it s ≡
(the (it s (case_option True (λ_. False)) (λx _. Some x) None))"
context begin interpretation autoref_syn .
lemma gen_pick[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm it)"
assumes NE: "SIDE_PRECOND (m'≠Map.empty)"
assumes SREF: "(m,m')∈⟨Rk,Rv⟩Rm"
shows "(RETURN (gen_pick (λx. foldli (it x)) m),
(OP op_map_pick ::: ⟨Rk,Rv⟩Rm→⟨Rk×⇩rRv⟩nres_rel)$m')∈⟨Rk×⇩rRv⟩nres_rel"
proof -
thm is_map_to_list_def is_map_to_sorted_listE
obtain tsl' where
[param]: "(it m,tsl') ∈ ⟨Rk×⇩rRv⟩list_rel"
and IT': "RETURN tsl' ≤ it_to_sorted_list (λ_ _. True) (map_to_set m')"
using IT[unfolded autoref_tag_defs is_map_to_list_def] SREF
by (auto intro: is_map_to_sorted_listE)
from IT' NE have "tsl'≠[]" and [simp]: "m'=map_of tsl'"
and DIS': "distinct (map fst tsl')"
unfolding it_to_sorted_list_def
apply simp_all
apply (metis empty_set map_to_set_empty_iff(1))
apply (metis map_of_map_to_set map_to_set_distinct_conv)
apply (metis map_to_set_distinct_conv)
done
then obtain k v where "m' k = Some v" and
"(foldli tsl' (case_option True (λ_. False)) (λx _. Some x) None)
= Some (k,v)"
(is "?fld = _")
by (cases rule: foldli_pick) auto
moreover
have "(RETURN (gen_pick (λx. foldli (it x)) m), RETURN (the ?fld))
∈ ⟨Rk×⇩rRv⟩nres_rel"
unfolding gen_pick_def
apply (parametricity add: the_paramR)
using ‹?fld = Some (k,v)›
by simp
ultimately show ?thesis
unfolding autoref_tag_defs
apply -
apply (drule nres_relD)
apply (rule nres_relI)
apply (erule ref_two_step)
by simp
qed
end
definition "gen_map_pick_remove pick del m ≡ do {
(k,v)←pick m;
let m = del k m;
RETURN ((k,v),m)
}"
context begin interpretation autoref_syn .
lemma gen_map_pick_remove
[unfolded gen_map_pick_remove_def, autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes PICK: "SIDE_GEN_OP (
(pick m,
(OP op_map_pick ::: ⟨Rk,Rv⟩Rm → ⟨Rk×⇩rRv⟩nres_rel)$m') ∈
⟨Rk×⇩rRv⟩nres_rel)"
assumes DEL: "GEN_OP del op_map_delete (Rk → ⟨Rk,Rv⟩Rm → ⟨Rk,Rv⟩Rm)"
assumes [param]: "(m,m')∈⟨Rk,Rv⟩Rm"
shows "(gen_map_pick_remove pick del m,
(OP op_map_pick_remove
::: ⟨Rk,Rv⟩Rm → ⟨(Rk×⇩rRv) ×⇩r ⟨Rk,Rv⟩Rm⟩nres_rel)$m')
∈ ⟨(Rk×⇩rRv) ×⇩r ⟨Rk,Rv⟩Rm⟩nres_rel"
proof -
note [param] =
PICK[unfolded autoref_tag_defs]
DEL[unfolded autoref_tag_defs]
have "(gen_map_pick_remove pick del m,
do {
(k,v)←op_map_pick m';
let m' = op_map_delete k m';
RETURN ((k,v),m')
}) ∈ ⟨(Rk×⇩rRv) ×⇩r ⟨Rk,Rv⟩Rm⟩nres_rel" (is "(_,?h):_")
unfolding gen_map_pick_remove_def[abs_def]
apply parametricity
done
also have "?h = op_map_pick_remove m'"
by (auto simp add: pw_eq_iff refine_pw_simps)
finally show ?thesis by simp
qed
end
end
Theory Gen_Map2Set
section ‹\isaheader{Generic Map To Set Converter}›
theory Gen_Map2Set
imports
"../Intf/Intf_Map"
"../Intf/Intf_Set"
"../Intf/Intf_Comp"
"../../Iterator/Iterator"
begin
lemma map_fst_unit_distinct_eq[simp]:
fixes l :: "('k×unit) list"
shows "distinct (map fst l) ⟷ distinct l"
by (induct l) auto
definition
map2set_rel :: "
(('ki×'k) set ⇒ (unit×unit) set ⇒ ('mi×('k⇀unit))set) ⇒
('ki×'k) set ⇒
('mi×('k set)) set"
where
map2set_rel_def_internal:
"map2set_rel R Rk ≡ ⟨Rk,Id::(unit×_) set⟩R O {(m,dom m)| m. True}"
lemma map2set_rel_def: "⟨Rk⟩(map2set_rel R)
= ⟨Rk,Id::(unit×_) set⟩R O {(m,dom m)| m. True}"
unfolding map2set_rel_def_internal[abs_def] by (simp add: relAPP_def)
lemma map2set_relI:
assumes "(s,m')∈⟨Rk,Id⟩R" and "s'=dom m'"
shows "(s,s')∈⟨Rk⟩map2set_rel R"
using assms unfolding map2set_rel_def by blast
lemma map2set_relE:
assumes "(s,s')∈⟨Rk⟩map2set_rel R"
obtains m' where "(s,m')∈⟨Rk,Id⟩R" and "s'=dom m'"
using assms unfolding map2set_rel_def by blast
lemma map2set_rel_sv[relator_props]:
"single_valued (⟨Rk,Id⟩Rm) ⟹ single_valued (⟨Rk⟩map2set_rel Rm)"
unfolding map2set_rel_def
by (auto intro: single_valuedI dest: single_valuedD)
lemma map2set_empty[autoref_rules_raw]:
assumes "PRIO_TAG_GEN_ALGO"
assumes "GEN_OP e op_map_empty (⟨Rk,Id⟩R)"
shows "(e,{})∈⟨Rk⟩map2set_rel R"
using assms
unfolding map2set_rel_def
by auto
lemmas [autoref_rel_intf] =
REL_INTFI[of "map2set_rel R" i_set] for R
definition "map2set_insert i k s ≡ i k () s"
lemma map2set_insert[autoref_rules_raw]:
assumes "PRIO_TAG_GEN_ALGO"
assumes "GEN_OP i op_map_update (Rk → Id → ⟨Rk,Id⟩R → ⟨Rk,Id⟩R)"
shows
"(map2set_insert i,Set.insert)∈Rk→⟨Rk⟩map2set_rel R → ⟨Rk⟩map2set_rel R"
using assms
unfolding map2set_rel_def map2set_insert_def[abs_def]
by (force dest: fun_relD)
definition "map2set_memb l k s ≡ case l k s of None ⇒ False | Some _ ⇒ True"
lemma map2set_memb[autoref_rules_raw]:
assumes "PRIO_TAG_GEN_ALGO"
assumes "GEN_OP l op_map_lookup (Rk → ⟨Rk,Id⟩R → ⟨Id⟩option_rel)"
shows "(map2set_memb l ,(∈))
∈ Rk→⟨Rk⟩map2set_rel R→Id"
using assms
unfolding map2set_rel_def map2set_memb_def[abs_def]
by (force dest: fun_relD split: option.splits)
lemma map2set_delete[autoref_rules_raw]:
assumes "PRIO_TAG_GEN_ALGO"
assumes "GEN_OP d op_map_delete (Rk→⟨Rk,Id⟩R→⟨Rk,Id⟩R)"
shows "(d,op_set_delete)∈Rk→⟨Rk⟩map2set_rel R→⟨Rk⟩map2set_rel R"
using assms
unfolding map2set_rel_def
by (force dest: fun_relD)
lemma map2set_to_sorted_list[autoref_ga_rules]:
fixes it :: "'m ⇒ ('k×unit) list"
assumes A: "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Id R it)"
shows "is_set_to_sorted_list ordR Rk (map2set_rel R)
(it_to_list (map_iterator_dom o (foldli o it)))"
proof -
{
fix l::"('k×unit) list"
have "⋀l0. foldli l (λ_. True) (λx σ. σ @ [fst x]) l0 = l0@map fst l"
by (induct l) auto
}
hence S: "it_to_list (map_iterator_dom o (foldli o it)) = map fst o it"
unfolding it_to_list_def[abs_def] map_iterator_dom_def[abs_def]
set_iterator_image_def set_iterator_image_filter_def
by (auto)
show ?thesis
unfolding S
using assms
unfolding is_map_to_sorted_list_def is_set_to_sorted_list_def
apply clarsimp
apply (erule map2set_relE)
apply (drule spec, drule spec)
apply (drule (1) mp)
apply (elim exE conjE)
apply (rule_tac x="map fst l'" in exI)
apply (rule conjI)
apply parametricity
unfolding it_to_sorted_list_def
apply (simp add: map_to_set_dom)
apply (simp add: sorted_wrt_map key_rel_def[abs_def])
done
qed
lemma map2set_to_list[autoref_ga_rules]:
fixes it :: "'m ⇒ ('k×unit) list"
assumes A: "GEN_ALGO_tag (is_map_to_list Rk Id R it)"
shows "is_set_to_list Rk (map2set_rel R)
(it_to_list (map_iterator_dom o (foldli o it)))"
using assms unfolding is_set_to_list_def is_map_to_list_def
by (rule map2set_to_sorted_list)
text ‹Transfering also non-basic operations results in specializations
of map-algorithms to also be used for sets›
lemma map2set_union[autoref_rules_raw]:
assumes "MINOR_PRIO_TAG (- 9)"
assumes "GEN_OP u (++) (⟨Rk,Id⟩R→⟨Rk,Id⟩R→⟨Rk,Id⟩R)"
shows "(u,(∪))∈⟨Rk⟩map2set_rel R→⟨Rk⟩map2set_rel R→⟨Rk⟩map2set_rel R"
using assms
unfolding map2set_rel_def
by (force dest: fun_relD)
lemmas [autoref_ga_rules] = cmp_unit_eq_linorder
lemmas [autoref_rules_raw] = param_cmp_unit
lemma cmp_lex_zip_unit[simp]:
"cmp_lex (cmp_prod cmp cmp_unit) (map (λk. (k, ())) l)
(map (λk. (k, ())) m) =
cmp_lex cmp l m"
apply (induct cmp l m rule: cmp_lex.induct)
apply (auto split: comp_res.split)
done
lemma cmp_img_zip_unit[simp]:
"cmp_img (λm. map (λk. (k,())) (f m)) (cmp_lex (cmp_prod cmp1 cmp_unit))
= cmp_img f (cmp_lex cmp1)"
unfolding cmp_img_def[abs_def]
apply (intro ext)
apply simp
done
lemma map2set_finite[relator_props]:
assumes "finite_map_rel (⟨Rk,Id⟩R)"
shows "finite_set_rel (⟨Rk⟩map2set_rel R)"
using assms
unfolding map2set_rel_def finite_set_rel_def finite_map_rel_def
by auto
lemma map2set_cmp[autoref_rules_raw]:
assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmpk)"
assumes MPAR:
"GEN_OP cmp (cmp_map cmpk cmp_unit) (⟨Rk,Id⟩R → ⟨Rk,Id⟩R → Id)"
assumes FIN: "PREFER finite_map_rel (⟨Rk, Id⟩R)"
shows "(cmp,cmp_set cmpk)∈⟨Rk⟩map2set_rel R → ⟨Rk⟩map2set_rel R → Id"
proof -
interpret linorder "comp2le cmpk" "comp2lt cmpk"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
using MPAR
unfolding cmp_map_def cmp_set_def
apply simp
apply parametricity
apply (drule cmp_extend_paramD)
apply (insert FIN, fastforce simp add: finite_map_rel_def) []
apply (simp add: sorted_list_of_map_def[abs_def])
apply (auto simp: map2set_rel_def cmp_img_def[abs_def] dest: fun_relD) []
apply (insert map2set_finite[OF FIN[unfolded autoref_tag_defs]],
fastforce simp add: finite_set_rel_def)
done
qed
end
Theory Gen_Comp
section ‹\isaheader{Generic Compare Algorithms}›
theory Gen_Comp
imports
"../Intf/Intf_Comp"
Automatic_Refinement.Automatic_Refinement
"HOL-Library.Product_Lexorder"
begin
subsection ‹Order for Product›
lemma autoref_prod_cmp_dflt_id[autoref_rules_raw]:
"(dflt_cmp (≤) (<), dflt_cmp (≤) (<)) ∈
⟨Id,Id⟩prod_rel → ⟨Id,Id⟩prod_rel → Id"
by auto
lemma gen_prod_cmp_dflt[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes "GEN_OP cmp1 (dflt_cmp (≤) (<)) (R1 → R1 → Id)"
assumes "GEN_OP cmp2 (dflt_cmp (≤) (<)) (R2 → R2 → Id)"
shows "(cmp_prod cmp1 cmp2, dflt_cmp (≤) (<)) ∈
⟨R1,R2⟩prod_rel → ⟨R1,R2⟩prod_rel → Id"
proof -
have E: "dflt_cmp (≤) (<)
= cmp_prod (dflt_cmp (≤) (<)) (dflt_cmp (≤) (<))"
by (auto simp: dflt_cmp_def prod_less_def prod_le_def intro!: ext)
show ?thesis
using assms
unfolding autoref_tag_defs E
by parametricity
qed
end
Theory GenCF_Impl_Chapter
theory GenCF_Impl_Chapter imports Main begin
text_raw ‹\isasection{Implementations}›
end
Theory Impl_Array_Stack
section ‹Stack by Array›
theory Impl_Array_Stack
imports
Automatic_Refinement.Automatic_Refinement
"../../Lib/Diff_Array"
begin
type_synonym 'a array_stack = "'a array × nat"
term Diff_Array.array_length
definition "as_raw_α s ≡ take (snd s) (list_of_array (fst s))"
definition "as_raw_invar s ≡ snd s ≤ array_length (fst s)"
definition as_rel_def_internal: "as_rel R ≡ br as_raw_α as_raw_invar O ⟨R⟩list_rel"
lemma as_rel_def: "⟨R⟩as_rel ≡ br as_raw_α as_raw_invar O ⟨R⟩list_rel"
unfolding as_rel_def_internal[abs_def] by (simp add: relAPP_def)
lemma [relator_props]: "single_valued R ⟹ single_valued (⟨R⟩as_rel)"
unfolding as_rel_def
by tagged_solver
lemmas [autoref_rel_intf] = REL_INTFI[of as_rel i_list]
definition "as_empty (_::unit) ≡ (array_of_list [],0)"
lemma as_empty_refine[autoref_rules]: "(as_empty (),[]) ∈ ⟨R⟩as_rel"
unfolding as_rel_def as_empty_def br_def
unfolding as_raw_α_def as_raw_invar_def
by auto
definition "as_push s x ≡ let
(a,n)=s;
a = if n = array_length a then
array_grow a (max 4 (2*n)) x
else a;
a = array_set a n x
in
(a,n+1)"
lemma as_push_refine[autoref_rules]:
"(as_push,op_list_append_elem) ∈ ⟨R⟩as_rel → R → ⟨R⟩as_rel"
apply (intro fun_relI)
apply (simp add: as_push_def op_list_append_elem_def as_rel_def br_def
as_raw_α_def as_raw_invar_def)
apply clarsimp
apply safe
apply (rule)
apply auto []
apply (clarsimp simp: array_length_list) []
apply parametricity
apply rule
apply auto []
apply (auto simp: take_Suc_conv_app_nth array_length_list list_update_append) []
apply parametricity
done
term array_shrink
definition "as_shrink s ≡ let
(a,n) = s;
a = if 128*n ≤ array_length a ∧ n>4 then
array_shrink a n
else a
in
(a,n)"
lemma as_shrink_id_refine: "(as_shrink,id) ∈ ⟨R⟩as_rel → ⟨R⟩as_rel"
apply (intro fun_relI)
apply (simp add: as_shrink_def as_rel_def br_def
as_raw_α_def as_raw_invar_def Let_def)
apply clarsimp
apply safe
apply (rule)
apply (auto simp: array_length_list)
done
lemma as_shrinkI:
assumes [param]: "(s,a)∈⟨R⟩as_rel"
shows "(as_shrink s,a)∈⟨R⟩as_rel"
apply (subst id_apply[of a,symmetric])
apply (parametricity add: as_shrink_id_refine)
done
definition "as_pop s ≡ let (a,n)=s in as_shrink (a,n - 1)"
lemma as_pop_refine[autoref_rules]: "(as_pop,butlast) ∈ ⟨R⟩as_rel → ⟨R⟩as_rel"
apply (intro fun_relI)
apply (clarsimp simp add: as_pop_def split: prod.split)
apply (rule as_shrinkI)
apply (simp add: as_pop_def as_rel_def br_def
as_raw_α_def as_raw_invar_def Let_def)
apply clarsimp
apply rule
apply (auto simp: array_length_list) []
apply (clarsimp simp: array_length_list take_minus_one_conv_butlast) []
apply parametricity
done
definition "as_get s i ≡ let (a,_::nat)=s in array_get a i"
lemma as_get_refine:
assumes 1: "i'<length l"
assumes 2: "(a,l)∈⟨R⟩as_rel"
assumes 3[param]: "(i,i')∈nat_rel"
shows "(as_get a i,l!i')∈R"
using 2
apply (clarsimp
simp add: as_get_def as_rel_def br_def as_raw_α_def as_raw_invar_def
split: prod.split)
apply (rename_tac aa bb)
apply (case_tac aa, simp)
proof -
fix n cl
assume TKR[param]: "(take n cl, l) ∈ ⟨R⟩list_rel"
have "(take n cl!i, l!i')∈R"
by parametricity (rule 1)
also have "take n cl!i = cl!i"
using 1 3 list_rel_imp_same_length[OF TKR]
by simp
finally show "(cl!i,l!i')∈R" .
qed
context begin interpretation autoref_syn .
lemma as_get_autoref[autoref_rules]:
assumes "(l,l')∈⟨R⟩as_rel"
assumes "(i,i')∈Id"
assumes "SIDE_PRECOND (i' < length l')"
shows "(as_get l i,(OP nth ::: ⟨R⟩as_rel → nat_rel → R)$l'$i')∈R"
using assms by (simp add: as_get_refine)
definition "as_set s i x ≡ let (a,n::nat)=s in (array_set a i x,n)"
lemma as_set_refine[autoref_rules]:
"(as_set,list_update)∈⟨R⟩as_rel → nat_rel → R → ⟨R⟩as_rel"
apply (intro fun_relI)
apply (clarsimp
simp: as_set_def as_rel_def br_def as_raw_α_def as_raw_invar_def
split: prod.split)
apply rule
apply auto []
apply parametricity
by simp
definition as_length :: "'a array_stack ⇒ nat" where
"as_length = snd"
lemma as_length_refine[autoref_rules]:
"(as_length,length) ∈ ⟨R⟩as_rel → nat_rel"
by (auto
simp: as_length_def as_rel_def br_def as_raw_α_def as_raw_invar_def
array_length_list
dest!: list_rel_imp_same_length
)
definition "as_top s ≡ as_get s (as_length s - 1)"
lemma as_top_code[code]: "as_top s = (let (a,n)=s in array_get a (n - 1))"
unfolding as_top_def as_get_def as_length_def
by (auto split: prod.split)
lemma as_top_refine: "⟦l≠[]; (s,l)∈⟨R⟩as_rel⟧ ⟹ (as_top s,last l)∈R"
unfolding as_top_def
apply (simp add: last_conv_nth)
apply (rule as_get_refine)
apply (auto simp: as_length_def as_rel_def br_def as_raw_α_def
as_raw_invar_def array_length_list
dest!: list_rel_imp_same_length)
done
lemma as_top_autoref[autoref_rules]:
assumes "(l,l')∈⟨R⟩as_rel"
assumes "SIDE_PRECOND (l' ≠ [])"
shows "(as_top l,(OP last ::: ⟨R⟩as_rel → R)$l')∈R"
using assms by (simp add: as_top_refine)
definition "as_is_empty s ≡ as_length s = 0"
lemma as_is_empty_code[code]: "as_is_empty s = (snd s = 0)"
unfolding as_is_empty_def as_length_def by simp
lemma as_is_empty_refine[autoref_rules]:
"(as_is_empty,is_Nil) ∈ ⟨R⟩as_rel → bool_rel"
proof
fix s l
assume [param]: "(s,l)∈⟨R⟩as_rel"
have "(as_is_empty s,length l = 0) ∈ bool_rel"
unfolding as_is_empty_def
by (parametricity add: as_length_refine)
also have "length l = 0 ⟷ is_Nil l"
by (cases l) auto
finally show "(as_is_empty s, is_Nil l) ∈ bool_rel" .
qed
definition "as_take m s ≡ let (a,n) = s in
if m<n then
as_shrink (a,m)
else (a,n)"
lemma as_take_refine[autoref_rules]:
"(as_take,take)∈nat_rel → ⟨R⟩as_rel → ⟨R⟩as_rel"
apply (intro fun_relI)
apply (clarsimp simp add: as_take_def, safe)
apply (rule as_shrinkI)
apply (simp add: as_rel_def br_def as_raw_α_def as_raw_invar_def)
apply rule
apply auto []
apply clarsimp
apply (subgoal_tac "take a' (list_of_array a) = take a' (take ba (list_of_array a))")
apply (simp only: )
apply (parametricity, rule IdI)
apply simp
apply (simp add: as_rel_def br_def as_raw_α_def as_raw_invar_def)
apply rule
apply auto []
apply clarsimp
apply (frule list_rel_imp_same_length)
apply simp
done
definition "as_singleton x ≡ (array_of_list [x],1)"
lemma as_singleton_refine[autoref_rules]:
"(as_singleton,op_list_singleton)∈R → ⟨R⟩as_rel"
apply (intro fun_relI)
apply (simp add: as_singleton_def as_rel_def br_def as_raw_α_def
as_raw_invar_def)
apply rule
apply (auto simp: array_length_list) []
apply simp
done
end
end
Theory Impl_List_Set
section ‹\isaheader{List Based Sets}›
theory Impl_List_Set
imports
"../../Iterator/Iterator"
"../Intf/Intf_Set"
begin
lemma list_all2_refl_conv:
"list_all2 P xs xs ⟷ (∀x∈set xs. P x x)"
by (induct xs) auto
primrec glist_member :: "('a⇒'a⇒bool) ⇒ 'a ⇒ 'a list ⇒ bool" where
"glist_member eq x [] ⟷ False"
| "glist_member eq x (y#ys) ⟷ eq x y ∨ glist_member eq x ys"
lemma param_glist_member[param]:
"(glist_member,glist_member)∈(Ra→Ra→Id) → Ra → ⟨Ra⟩list_rel → Id"
unfolding glist_member_def
by (parametricity)
lemma list_member_alt: "List.member = (λl x. glist_member (=) x l)"
proof (intro ext)
fix x l
show "List.member l x = glist_member (=) x l"
by (induct l) (auto simp: List.member_rec)
qed
thm List.insert_def
definition
"glist_insert eq x xs = (if glist_member eq x xs then xs else x#xs)"
lemma param_glist_insert[param]:
"(glist_insert, glist_insert) ∈ (R→R→Id) → R → ⟨R⟩list_rel → ⟨R⟩list_rel"
unfolding glist_insert_def[abs_def]
by (parametricity)
primrec rev_append where
"rev_append [] ac = ac"
| "rev_append (x#xs) ac = rev_append xs (x#ac)"
lemma rev_append_eq: "rev_append l ac = rev l @ ac"
by (induct l arbitrary: ac) auto
primrec glist_delete_aux :: "('a ⇒ 'a ⇒ bool) ⇒ _" where
"glist_delete_aux eq x [] as = as"
| "glist_delete_aux eq x (y#ys) as = (
if eq x y then rev_append as ys
else glist_delete_aux eq x ys (y#as)
)"
definition glist_delete where
"glist_delete eq x l ≡ glist_delete_aux eq x l []"
lemma param_glist_delete[param]:
"(glist_delete, glist_delete) ∈ (R→R→Id) → R → ⟨R⟩list_rel → ⟨R⟩list_rel"
unfolding glist_delete_def[abs_def]
glist_delete_aux_def
rev_append_def
by (parametricity)
lemma list_rel_Range:
"∀x'∈set l'. x' ∈ Range R ⟹ l' ∈ Range (⟨R⟩list_rel)"
proof (induction l')
case Nil thus ?case by force
next
case (Cons x' xs')
then obtain xs where "(xs,xs') ∈ ⟨R⟩ list_rel" by force
moreover from Cons.prems obtain x where "(x,x') ∈ R" by force
ultimately have "(x#xs, x'#xs') ∈ ⟨R⟩ list_rel" by simp
thus ?case ..
qed
text ‹All finite sets can be represented›
lemma list_set_rel_range:
"Range (⟨R⟩list_set_rel) = { S. finite S ∧ S⊆Range R }"
(is "?A = ?B")
proof (intro equalityI subsetI)
fix s' assume "s' ∈ ?A"
then obtain l l' where A: "(l,l') ∈ ⟨R⟩list_rel" and
B: "s' = set l'" and C: "distinct l'"
unfolding list_set_rel_def br_def by blast
moreover have "set l' ⊆ Range R"
by (induction rule: list_rel_induct[OF A], auto)
ultimately show "s' ∈ ?B" by simp
next
fix s' assume A: "s' ∈ ?B"
then obtain l' where B: "set l' = s'" and C: "distinct l'"
using finite_distinct_list by blast
hence "(l',s') ∈ br set distinct" by (simp add: br_def)
moreover from A and B have "∀x∈set l'. x ∈ Range R" by blast
from list_rel_Range[OF this] obtain l
where "(l,l') ∈ ⟨R⟩list_rel" by blast
ultimately show "s' ∈ ?A" unfolding list_set_rel_def by fast
qed
lemmas [autoref_rel_intf] = REL_INTFI[of list_set_rel i_set]
lemma list_set_rel_finite[autoref_ga_rules]:
"finite_set_rel (⟨R⟩list_set_rel)"
unfolding finite_set_rel_def list_set_rel_def
by (auto simp: br_def)
lemma list_set_rel_sv[relator_props]:
"single_valued R ⟹ single_valued (⟨R⟩list_set_rel)"
unfolding list_set_rel_def
by tagged_solver
lemma Id_comp_Id: "Id O Id = Id" by simp
lemma glist_member_id_impl:
"(glist_member (=), (∈)) ∈ Id → br set distinct → Id"
proof (intro fun_relI, goal_cases)
case (1 x x' l s') thus ?case
by (induct l arbitrary: s') (auto simp: br_def)
qed
lemma glist_insert_id_impl:
"(glist_insert (=), Set.insert) ∈ Id → br set distinct → br set distinct"
proof -
have IC: "⋀x s. insert x s = (if x∈s then s else insert x s)" by auto
show ?thesis
apply (intro fun_relI)
apply (subst IC)
unfolding glist_insert_def
apply (parametricity add: glist_member_id_impl)
apply (auto simp: br_def)
done
qed
lemma glist_delete_id_impl:
"(glist_delete (=), λx s. s-{x})
∈ Id→br set distinct → br set distinct"
proof (intro fun_relI)
fix x x':: 'a and s and s' :: "'a set"
assume XREL: "(x, x') ∈ Id" and SREL: "(s, s') ∈ br set distinct"
from XREL have [simp]: "x'=x" by simp
{
fix a and a' :: "'a set"
assume "(a,a')∈br set distinct" and "s' ∩ a' = {}"
hence "(glist_delete_aux (=) x s a, s'-{x'} ∪ a')∈br set distinct"
using SREL
proof (induction s arbitrary: a s' a')
case Nil thus ?case by (simp add: br_def)
next
case (Cons y s)
show ?case proof (cases "x=y")
case True with Cons show ?thesis
by (auto simp add: br_def rev_append_eq)
next
case False
have "glist_delete_aux (=) x (y # s) a
= glist_delete_aux (=) x s (y#a)" by (simp add: False)
also have "(…,set s - {x'} ∪ insert y a')∈br set distinct"
apply (rule Cons.IH[of "y#a" "insert y a'" "set s"])
using Cons.prems by (auto simp: br_def)
also have "set s - {x'} ∪ insert y a' = (s' - {x'}) ∪ a'"
proof -
from Cons.prems have [simp]: "s' = insert y (set s)"
by (auto simp: br_def)
show ?thesis using False by auto
qed
finally show ?thesis .
qed
qed
}
from this[of "[]" "{}"]
show "(glist_delete (=) x s, s' - {x'}) ∈ br set distinct"
unfolding glist_delete_def
by (simp add: br_def)
qed
lemma list_set_autoref_empty[autoref_rules]:
"([],{})∈⟨R⟩list_set_rel"
by (auto simp: list_set_rel_def br_def)
lemma list_set_autoref_member[autoref_rules]:
assumes "GEN_OP eq (=) (R→R→Id)"
shows "(glist_member eq,(∈)) ∈ R → ⟨R⟩list_set_rel → Id"
using assms
apply (intro fun_relI)
unfolding list_set_rel_def
apply (erule relcompE)
apply (simp del: pair_in_Id_conv)
apply (subst Id_comp_Id[symmetric])
apply (rule relcompI[rotated])
apply (rule glist_member_id_impl[param_fo])
apply (rule IdI)
apply assumption
apply parametricity
done
lemma list_set_autoref_insert[autoref_rules]:
assumes "GEN_OP eq (=) (R→R→Id)"
shows "(glist_insert eq,Set.insert)
∈ R → ⟨R⟩list_set_rel → ⟨R⟩list_set_rel"
using assms
apply (intro fun_relI)
unfolding list_set_rel_def
apply (erule relcompE)
apply (simp del: pair_in_Id_conv)
apply (rule relcompI[rotated])
apply (rule glist_insert_id_impl[param_fo])
apply (rule IdI)
apply assumption
apply parametricity
done
lemma list_set_autoref_delete[autoref_rules]:
assumes "GEN_OP eq (=) (R→R→Id)"
shows "(glist_delete eq,op_set_delete)
∈ R → ⟨R⟩list_set_rel → ⟨R⟩list_set_rel"
using assms
apply (intro fun_relI)
unfolding list_set_rel_def
apply (erule relcompE)
apply (simp del: pair_in_Id_conv)
apply (rule relcompI[rotated])
apply (rule glist_delete_id_impl[param_fo])
apply (rule IdI)
apply assumption
apply parametricity
done
lemma list_set_autoref_to_list[autoref_ga_rules]:
shows "is_set_to_sorted_list (λ_ _. True) R list_set_rel id"
unfolding is_set_to_list_def is_set_to_sorted_list_def
it_to_sorted_list_def list_set_rel_def br_def
by auto
lemma list_set_it_simp[refine_transfer_post_simp]:
"foldli (id l) = foldli l" by simp
lemma glist_insert_dj_id_impl:
"⟦ x∉s; (l,s)∈br set distinct ⟧ ⟹ (x#l,insert x s)∈br set distinct"
by (auto simp: br_def)
context begin interpretation autoref_syn .
lemma list_set_autoref_insert_dj[autoref_rules]:
assumes "PRIO_TAG_OPTIMIZATION"
assumes "SIDE_PRECOND_OPT (x'∉s')"
assumes "(x,x')∈R"
assumes "(s,s')∈⟨R⟩list_set_rel"
shows "(x#s,
(OP Set.insert ::: R → ⟨R⟩list_set_rel → ⟨R⟩list_set_rel) $ x' $ s')
∈ ⟨R⟩list_set_rel"
using assms
unfolding autoref_tag_defs
unfolding list_set_rel_def
apply -
apply (erule relcompE)
apply (simp del: pair_in_Id_conv)
apply (rule relcompI[rotated])
apply (rule glist_insert_dj_id_impl)
apply assumption
apply assumption
apply parametricity
done
end
subsection ‹More Operations›
lemma list_set_autoref_isEmpty[autoref_rules]:
"(is_Nil,op_set_isEmpty) ∈ ⟨R⟩list_set_rel → bool_rel"
by (auto simp: list_set_rel_def br_def split: list.split_asm)
lemma list_set_autoref_filter[autoref_rules]:
"(filter,op_set_filter)
∈ (R → bool_rel) → ⟨R⟩list_set_rel → ⟨R⟩list_set_rel"
proof -
have "(filter, op_set_filter)
∈ (Id → bool_rel) → ⟨Id⟩list_set_rel → ⟨Id⟩list_set_rel"
by (auto simp: list_set_rel_def br_def)
note this[param_fo]
moreover have "(filter,filter)∈(R → bool_rel) → ⟨R⟩list_rel → ⟨R⟩list_rel"
unfolding List.filter_def
by parametricity
note this[param_fo]
ultimately show ?thesis
unfolding list_set_rel_def
apply (intro fun_relI)
apply (erule relcompE, simp)
apply (rule relcompI)
apply (rprems, assumption+)
apply (rprems, simp+)
done
qed
context begin interpretation autoref_syn .
lemma list_set_autoref_inj_image[autoref_rules]:
assumes "PRIO_TAG_OPTIMIZATION"
assumes INJ: "SIDE_PRECOND_OPT (inj_on f s)"
assumes [param]: "(fi,f)∈Ra→Rb"
assumes LP: "(l,s)∈⟨Ra⟩list_set_rel"
shows "(map fi l,
(OP (`) ::: (Ra→Rb) → ⟨Ra⟩list_set_rel → ⟨Rb⟩list_set_rel)$f$s)
∈ ⟨Rb⟩list_set_rel"
proof -
from LP obtain l' where
[param]: "(l,l')∈⟨Ra⟩list_rel" and L'S: "(l',s)∈br set distinct"
unfolding list_set_rel_def by auto
have "(map fi l, map f l')∈⟨Rb⟩list_rel" by parametricity
also from INJ L'S have "(map f l',f`s)∈br set distinct"
apply (induction l' arbitrary: s)
apply (auto simp: br_def dest: injD)
done
finally (relcompI) show ?thesis
unfolding autoref_tag_defs list_set_rel_def .
qed
end
lemma list_set_cart_autoref[autoref_rules]:
fixes Rx :: "('xi × 'x) set"
fixes Ry :: "('yi × 'y) set"
shows "(λxl yl. [ (x,y). x←xl, y←yl], op_set_cart)
∈ ⟨Rx⟩list_set_rel → ⟨Ry⟩list_set_rel → ⟨Rx ×⇩r Ry⟩list_set_rel"
proof (intro fun_relI)
fix xl xs yl ys
assume "(xl, xs) ∈ ⟨Rx⟩list_set_rel" "(yl, ys) ∈ ⟨Ry⟩list_set_rel"
then obtain xl' :: "'x list" and yl' :: "'y list" where
[param]: "(xl,xl')∈⟨Rx⟩list_rel" "(yl,yl')∈⟨Ry⟩list_rel"
and XLS: "(xl',xs)∈br set distinct" and YLS: "(yl',ys)∈br set distinct"
unfolding list_set_rel_def
by auto
have "([ (x,y). x←xl, y←yl ], [ (x,y). x←xl', y←yl' ])
∈ ⟨Rx ×⇩r Ry⟩list_rel"
by parametricity
also have "([ (x,y). x←xl', y←yl' ], xs × ys) ∈ br set distinct"
using XLS YLS
apply (auto simp: br_def)
apply hypsubst_thin
apply (induction xl')
apply simp
apply (induction yl')
apply simp
apply auto []
apply (metis (lifting) concat_map_maps distinct.simps(2)
distinct_singleton maps_simps(2))
done
finally (relcompI)
show "([ (x,y). x←xl, y←yl ], op_set_cart xs ys) ∈ ⟨Rx ×⇩r Ry⟩list_set_rel"
unfolding list_set_rel_def by simp
qed
subsection ‹Optimizations›
lemma glist_delete_hd: "eq x y ⟹ glist_delete eq x (y#s) = s"
by (simp add: glist_delete_def)
text ‹Hack to ensure specific ordering. Note that ordering has no meaning
abstractly›
definition [simp]: "LIST_SET_REV_TAG ≡ λx. x"
lemma LIST_SET_REV_TAG_autoref[autoref_rules]:
"(rev,LIST_SET_REV_TAG) ∈ ⟨R⟩list_set_rel → ⟨R⟩list_set_rel"
unfolding list_set_rel_def
apply (intro fun_relI)
apply (elim relcompE)
apply (clarsimp simp: br_def)
apply (rule relcompI)
apply (rule param_rev[param_fo], assumption)
apply auto
done
end
Theory Array_Iterator
theory Array_Iterator
imports Iterator "../Lib/Diff_Array"
begin
lemma idx_iteratei_aux_array_get_Array_conv_nth:
"idx_iteratei_aux array_get sz i (Array xs) c f σ =
idx_iteratei_aux (!) sz i xs c f σ"
apply(induct get≡"(!) :: 'b list ⇒ nat ⇒ 'b" sz i xs c f σ rule: idx_iteratei_aux.induct)
apply(subst (1 2) idx_iteratei_aux.simps)
apply simp
done
lemma idx_iteratei_array_get_Array_conv_nth:
"idx_iteratei array_get array_length (Array xs) = idx_iteratei nth length xs"
by(simp add: idx_iteratei_def fun_eq_iff idx_iteratei_aux_array_get_Array_conv_nth)
end
Theory Impl_List_Map
section ‹\isaheader{List Based Maps}›
theory Impl_List_Map
imports
"../../Iterator/Iterator"
"../Gen/Gen_Map"
"../Intf/Intf_Comp"
"../Intf/Intf_Map"
begin
type_synonym ('k,'v) list_map = "('k×'v) list"
definition "list_map_invar = distinct o map fst"
definition list_map_rel_internal_def:
"list_map_rel Rk Rv ≡ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel O br map_of list_map_invar"
lemma list_map_rel_def:
"⟨Rk,Rv⟩list_map_rel = ⟨⟨Rk,Rv⟩prod_rel⟩list_rel O br map_of list_map_invar"
unfolding list_map_rel_internal_def[abs_def] by (simp add: relAPP_def)
lemma list_rel_Range:
"∀x'∈set l'. x' ∈ Range R ⟹ l' ∈ Range (⟨R⟩list_rel)"
proof (induction l')
case Nil thus ?case by force
next
case (Cons x' xs')
then obtain xs where "(xs,xs') ∈ ⟨R⟩ list_rel" by force
moreover from Cons.prems obtain x where "(x,x') ∈ R" by force
ultimately have "(x#xs, x'#xs') ∈ ⟨R⟩ list_rel" by simp
thus ?case ..
qed
text ‹All finite maps can be represented›
lemma list_map_rel_range:
"Range (⟨Rk,Rv⟩list_map_rel) =
{m. finite (dom m) ∧ dom m ⊆ Range Rk ∧ ran m ⊆ Range Rv}"
(is "?A = ?B")
proof (intro equalityI subsetI)
fix m' assume "m' ∈ ?A"
then obtain l l' where A: "(l,l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel" and
B: "m' = map_of l'" and C: "list_map_invar l'"
unfolding list_map_rel_def br_def by blast
{
fix x' y' assume "m' x' = Some y'"
with B have "(x',y') ∈ set l'" by (fast dest: map_of_SomeD)
hence "x' ∈ Range Rk" and "y' ∈ Range Rv"
by (induction rule: list_rel_induct[OF A], auto)
}
with B show "m' ∈ ?B" by (force dest: map_of_SomeD simp: ran_def)
next
fix m' assume "m' ∈ ?B"
hence A: "finite (dom m')" and B: "dom m' ⊆ Range Rk" and
C: "ran m' ⊆ Range Rv" by simp_all
from A have "finite (map_to_set m')" by (simp add: finite_map_to_set)
from finite_distinct_list[OF this]
obtain l' where l'_props: "distinct l'" "set l' = map_to_set m'" by blast
hence *: "distinct (map fst l')"
by (force simp: distinct_map inj_on_def map_to_set_def)
from map_of_map_to_set[OF this] and l'_props
have "map_of l' = m'" by simp
with * have "(l',m') ∈ br map_of list_map_invar"
unfolding br_def list_map_invar_def o_def by simp
moreover from B and C and l'_props
have "∀x ∈ set l'. x ∈ Range (⟨Rk,Rv⟩prod_rel)"
unfolding map_to_set_def ran_def prod_rel_def by force
from list_rel_Range[OF this] obtain l where
"(l,l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel" by force
ultimately show "m' ∈ ?A" unfolding list_map_rel_def by blast
qed
lemmas [autoref_rel_intf] = REL_INTFI[of list_map_rel i_map]
lemma list_map_rel_finite[autoref_ga_rules]:
"finite_map_rel (⟨Rk,Rv⟩list_map_rel)"
unfolding finite_map_rel_def list_map_rel_def
by (auto simp: br_def)
lemma list_map_rel_sv[relator_props]:
"single_valued Rk ⟹ single_valued Rv ⟹
single_valued (⟨Rk,Rv⟩list_map_rel)"
unfolding list_map_rel_def
by tagged_solver
subsection ‹Implementation›
primrec list_map_lookup ::
"('k ⇒ 'k ⇒ bool) ⇒ 'k ⇒ ('k,'v) list_map ⇒ 'v option" where
"list_map_lookup eq _ [] = None" |
"list_map_lookup eq k (y#ys) =
(if eq (fst y) k then Some (snd y) else list_map_lookup eq k ys)"
primrec list_map_update_aux :: "('k ⇒ 'k ⇒ bool) ⇒ 'k ⇒ 'v ⇒
('k,'v) list_map ⇒ ('k,'v) list_map ⇒ ('k,'v) list_map"where
"list_map_update_aux eq k v [] accu = (k,v) # accu" |
"list_map_update_aux eq k v (x#xs) accu =
(if eq (fst x) k
then (k,v) # xs @ accu
else list_map_update_aux eq k v xs (x#accu))"
definition "list_map_update eq k v m ≡
list_map_update_aux eq k v m []"
primrec list_map_delete_aux :: "('k ⇒ 'k ⇒ bool) ⇒ 'k ⇒
('k, 'v) list_map ⇒ ('k, 'v) list_map ⇒ ('k, 'v) list_map" where
"list_map_delete_aux eq k [] accu = accu" |
"list_map_delete_aux eq k (x#xs) accu =
(if eq (fst x) k
then xs @ accu
else list_map_delete_aux eq k xs (x#accu))"
definition "list_map_delete eq k m ≡ list_map_delete_aux eq k m []"
definition list_map_isEmpty :: "('k,'v) list_map ⇒ bool"
where "list_map_isEmpty ≡ List.null"
definition list_map_isSng :: "('k,'v) list_map ⇒ bool"
where "list_map_isSng m = (case m of [x] ⇒ True | _ ⇒ False)"
definition list_map_size :: "('k,'v) list_map ⇒ nat"
where "list_map_size ≡ length"
definition list_map_iteratei :: "('k,'v) list_map ⇒ ('b ⇒ bool) ⇒
(('k×'v) ⇒ 'b ⇒ 'b) ⇒ 'b ⇒ 'b"
where "list_map_iteratei ≡ foldli"
definition list_map_to_list :: "('k,'v) list_map ⇒ ('k×'v) list"
where "list_map_to_list = id"
subsection ‹Parametricity›
lemma list_map_autoref_empty[autoref_rules]:
"([], op_map_empty)∈⟨Rk,Rv⟩list_map_rel"
by (auto simp: list_map_rel_def br_def list_map_invar_def)
lemma param_list_map_lookup[param]:
"(list_map_lookup,list_map_lookup) ∈ (Rk → Rk → bool_rel) →
Rk → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨Rv⟩option_rel"
unfolding list_map_lookup_def[abs_def] by parametricity
lemma list_map_autoref_lookup_aux:
assumes eq: "GEN_OP eq (=) (Rk→Rk→Id)"
assumes K: "(k, k') ∈ Rk"
assumes M: "(m, m') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
shows "(list_map_lookup eq k m, op_map_lookup k' (map_of m'))
∈ ⟨Rv⟩option_rel"
unfolding op_map_lookup_def
proof (induction rule: list_rel_induct[OF M, case_names Nil Cons])
case Nil
show ?case by simp
next
case (Cons x x' xs xs')
from eq have eq': "(eq,(=)) ∈ Rk → Rk → Id" by simp
with eq'[param_fo] and K and Cons
show ?case by (force simp: prod_rel_def)
qed
lemma list_map_autoref_lookup[autoref_rules]:
assumes "GEN_OP eq (=) (Rk→Rk→Id)"
shows "(list_map_lookup eq, op_map_lookup) ∈
Rk → ⟨Rk,Rv⟩list_map_rel → ⟨Rv⟩option_rel"
by (force simp: list_map_rel_def br_def
dest: list_map_autoref_lookup_aux[OF assms])
lemma param_list_map_update_aux[param]:
"(list_map_update_aux,list_map_update_aux) ∈ (Rk → Rk → bool_rel) →
Rk → Rv → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel
→ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
unfolding list_map_update_aux_def[abs_def] by parametricity
lemma param_list_map_update[param]:
"(list_map_update,list_map_update) ∈ (Rk → Rk → bool_rel) →
Rk → Rv → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
unfolding list_map_update_def[abs_def] by parametricity
lemma list_map_autoref_update_aux1:
assumes eq: "(eq,(=)) ∈ Rk → Rk → Id"
assumes K: "(k, k') ∈ Rk"
assumes V: "(v, v') ∈ Rv"
assumes A: "(accu, accu') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
assumes M: "(m, m') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
shows "(list_map_update_aux eq k v m accu,
list_map_update_aux (=) k' v' m' accu')
∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
proof (insert A, induction arbitrary: accu accu'
rule: list_rel_induct[OF M, case_names Nil Cons])
case Nil
thus ?case by (simp add: K V)
next
case (Cons x x' xs xs')
from eq have eq': "(eq,(=)) ∈ Rk → Rk → Id" by simp
from eq'[param_fo] Cons(1) K
have [simp]: "(eq (fst x) k) ⟷ ((fst x') = k')"
by (force simp: prod_rel_def)
show ?case
proof (cases "eq (fst x) k")
case False
from Cons.prems and Cons.hyps have "(x # accu, x' # accu') ∈
⟨⟨Rk, Rv⟩prod_rel⟩list_rel" by parametricity
from Cons.IH[OF this] and False show ?thesis by simp
next
case True
from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') ∈
⟨⟨Rk, Rv⟩prod_rel⟩list_rel" by parametricity
with K and V and True show ?thesis by simp
qed
qed
lemma list_map_autoref_update1[param]:
assumes eq: "(eq,(=)) ∈ Rk → Rk → Id"
shows "(list_map_update eq, list_map_update (=)) ∈ Rk → Rv →
⟨⟨Rk, Rv⟩prod_rel⟩list_rel → ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
unfolding list_map_update_def[abs_def]
by (intro fun_relI, erule (1) list_map_autoref_update_aux1[OF eq],
simp_all)
lemma map_add_sng_right: "m ++ [k↦v] = m(k ↦ v)"
unfolding map_add_def by force
lemma map_add_sng_right':
"m ++ (λa. if a = k then Some v else None) = m(k ↦ v)"
unfolding map_add_def by force
lemma list_map_autoref_update_aux2:
assumes K: "(k, k') ∈ Id"
assumes V: "(v, v') ∈ Id"
assumes A: "(accu, accu') ∈ br map_of list_map_invar"
assumes A1: "distinct (map fst (m @ accu))"
assumes A2: "k ∉ set (map fst accu)"
assumes M: "(m, m') ∈ br map_of list_map_invar"
shows "(list_map_update_aux (=) k v m accu,
accu' ++ op_map_update k' v' m')
∈ br map_of list_map_invar" (is "(?f m accu, _) ∈ _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
case Nil
with K V show ?case by (auto simp: br_def list_map_invar_def
map_add_sng_right')
next
case (Cons x xs accu accu' m')
from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
unfolding br_def by simp_all
show ?case
proof (cases "(fst x) = k")
case True
hence "((k, v) # xs @ accu, accu' ++ op_map_update k' v' m')
∈ br map_of list_map_invar"
using K V Cons.prems(3,4) unfolding br_def
by (force simp add: A list_map_invar_def)
also from True have "(k,v) # xs @ accu = ?f (x # xs) accu" by simp
finally show ?thesis .
next
case False
from Cons.prems(1) have B: "(xs, map_of xs) ∈ br map_of
list_map_invar"by (simp add: br_def list_map_invar_def)
from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) ∈ br map_of
list_map_invar" by (simp add: br_def list_map_invar_def)
from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
by simp
from Cons.prems(4) and False have E: "k ∉ set (map fst (x # accu))"
by simp
note Cons.IH[OF B C D E]
also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
also from distinct_map_fstD[OF D]
have F: "⋀z. (fst x, z) ∈ set xs ⟹ z = snd x" by force
have "map_of (x # accu) ++ op_map_update k' v' (map_of xs) =
accu' ++ op_map_update k' v' m'"
by (intro ext, auto simp: A F map_add_def
dest: map_of_SomeD split: option.split)
finally show ?thesis .
qed
qed
lemma list_map_autoref_update2[param]:
shows "(list_map_update (=), op_map_update) ∈ Id → Id →
br map_of list_map_invar → br map_of list_map_invar"
unfolding list_map_update_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_update_aux2
[where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done
lemma list_map_autoref_update[autoref_rules]:
assumes eq: "GEN_OP eq (=) (Rk→Rk→Id)"
shows "(list_map_update eq, op_map_update) ∈
Rk → Rv → ⟨Rk,Rv⟩list_map_rel → ⟨Rk,Rv⟩list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (2) list_map_autoref_update1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_update2[param_fo], simp_all)
done
context begin interpretation autoref_syn .
lemma list_map_autoref_update_dj[autoref_rules]:
assumes "PRIO_TAG_OPTIMIZATION"
assumes new: "SIDE_PRECOND_OPT (k' ∉ dom m')"
assumes K: "(k,k')∈Rk" and V: "(v,v')∈Rv"
assumes M: "(l,m')∈⟨Rk, Rv⟩list_map_rel"
defines "R_annot ≡ Rk → Rv → ⟨Rk,Rv⟩list_map_rel → ⟨Rk,Rv⟩list_map_rel"
shows "
((k, v)#l,
(OP op_map_update:::R_annot)$k'$v'$m')
∈ ⟨Rk,Rv⟩list_map_rel"
proof -
from M obtain l' where A: "(l,l') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel" and
B: "(l',m') ∈ br map_of list_map_invar"
unfolding list_map_rel_def by blast
hence "((k,v)#l, (k',v')#l')∈⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
and "((k',v')#l', m'(k' ↦ v')) ∈ br map_of list_map_invar"
using assms unfolding br_def list_map_invar_def
by (simp_all add: dom_map_of_conv_image_fst)
thus ?thesis
unfolding autoref_tag_defs
by (force simp: list_map_rel_def)
qed
end
lemma param_list_map_delete_aux[param]:
"(list_map_delete_aux,list_map_delete_aux) ∈ (Rk → Rk → bool_rel) →
Rk → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel
→ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
unfolding list_map_delete_aux_def[abs_def] by parametricity
lemma param_list_map_delete[param]:
"(list_map_delete,list_map_delete) ∈ (Rk → Rk → bool_rel) →
Rk → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
unfolding list_map_delete_def[abs_def] by parametricity
lemma list_map_autoref_delete_aux1:
assumes eq: "(eq,(=)) ∈ Rk → Rk → Id"
assumes K: "(k, k') ∈ Rk"
assumes A: "(accu, accu') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
assumes M: "(m, m') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
shows "(list_map_delete_aux eq k m accu,
list_map_delete_aux (=) k' m' accu')
∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
proof (insert A, induction arbitrary: accu accu'
rule: list_rel_induct[OF M, case_names Nil Cons])
case Nil
thus ?case by (simp add: K)
next
case (Cons x x' xs xs')
from eq have eq': "(eq,(=)) ∈ Rk → Rk → Id" by simp
from eq'[param_fo] Cons(1) K
have [simp]: "(eq (fst x) k) ⟷ ((fst x') = k')"
by (force simp: prod_rel_def)
show ?case
proof (cases "eq (fst x) k")
case False
from Cons.prems and Cons.hyps have "(x # accu, x' # accu') ∈
⟨⟨Rk, Rv⟩prod_rel⟩list_rel" by parametricity
from Cons.IH[OF this] and False show ?thesis by simp
next
case True
from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') ∈
⟨⟨Rk, Rv⟩prod_rel⟩list_rel" by parametricity
with K and True show ?thesis by simp
qed
qed
lemma list_map_autoref_delete1[param]:
assumes eq: "(eq,(=)) ∈ Rk → Rk → Id"
shows "(list_map_delete eq, list_map_delete (=)) ∈ Rk →
⟨⟨Rk, Rv⟩prod_rel⟩list_rel → ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
unfolding list_map_delete_def[abs_def]
by (intro fun_relI, erule list_map_autoref_delete_aux1[OF eq],
simp_all)
lemma list_map_autoref_delete_aux2:
assumes K: "(k, k') ∈ Id"
assumes A: "(accu, accu') ∈ br map_of list_map_invar"
assumes A1: "distinct (map fst (m @ accu))"
assumes A2: "k ∉ set (map fst accu)"
assumes M: "(m, m') ∈ br map_of list_map_invar"
shows "(list_map_delete_aux (=) k m accu,
accu' ++ op_map_delete k' m')
∈ br map_of list_map_invar" (is "(?f m accu, _) ∈ _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
case Nil
with K show ?case by (auto simp: br_def list_map_invar_def
map_add_sng_right')
next
case (Cons x xs accu accu' m')
from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
unfolding br_def by simp_all
show ?case
proof (cases "(fst x) = k")
case True
with Cons.prems(3) have "map_of xs (fst x) = None"
by (induction xs, simp_all)
with fun_upd_triv[of "map_of xs" "fst x"]
have "map_of xs |` (- {fst x}) = map_of xs"
by (simp add: map_upd_eq_restrict)
with True have"(xs @ accu, accu' ++ op_map_delete k' m')
∈ br map_of list_map_invar"
using K Cons.prems unfolding br_def
by (auto simp add: A list_map_invar_def)
thus ?thesis using True by simp
next
case False
from False and K have [simp]: "fst x ≠ k'" by simp
from Cons.prems(1) have B: "(xs, map_of xs) ∈ br map_of
list_map_invar"by (simp add: br_def list_map_invar_def)
from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) ∈ br map_of
list_map_invar" by (simp add: br_def list_map_invar_def)
from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
by simp
from Cons.prems(4) and False have E: "k ∉ set (map fst (x # accu))"
by simp
note Cons.IH[OF B C D E]
also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
also from distinct_map_fstD[OF D]
have F: "⋀z. (fst x, z) ∈ set xs ⟹ z = snd x" by force
from Cons.prems(3) have "map_of xs (fst x) = None"
by (induction xs, simp_all)
hence "map_of (x # accu) ++ op_map_delete k' (map_of xs) =
accu' ++ op_map_delete k' m'"
apply (intro ext, simp add: map_add_def A
split: option.split)
apply (intro conjI impI allI)
apply (auto simp: restrict_map_def)
done
finally show ?thesis .
qed
qed
lemma list_map_autoref_delete2[param]:
shows "(list_map_delete (=), op_map_delete) ∈ Id →
br map_of list_map_invar → br map_of list_map_invar"
unfolding list_map_delete_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_delete_aux2
[where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done
lemma list_map_autoref_delete[autoref_rules]:
assumes eq: "GEN_OP eq (=) (Rk→Rk→Id)"
shows "(list_map_delete eq, op_map_delete) ∈
Rk → ⟨Rk,Rv⟩list_map_rel → ⟨Rk,Rv⟩list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (1) list_map_autoref_delete1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_delete2[param_fo], simp_all)
done
lemma list_map_autoref_isEmpty[autoref_rules]:
shows "(list_map_isEmpty, op_map_isEmpty) ∈
⟨Rk,Rv⟩list_map_rel → bool_rel"
unfolding list_map_isEmpty_def op_map_isEmpty_def[abs_def]
list_map_rel_def br_def List.null_def[abs_def] by force
lemma param_list_map_isSng[param]:
assumes "(l,l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
shows "(list_map_isSng l, list_map_isSng l') ∈ bool_rel"
unfolding list_map_isSng_def using assms by parametricity
lemma list_map_autoref_isSng_aux:
assumes "(l',m') ∈ br map_of list_map_invar"
shows "(list_map_isSng l', op_map_isSng m') ∈ bool_rel"
using assms
unfolding list_map_isSng_def op_map_isSng_def br_def list_map_invar_def
apply (clarsimp split: list.split)
apply (intro conjI impI allI)
apply (metis map_upd_nonempty)
apply blast
apply (simp, metis fun_upd_apply option.distinct(1))
done
lemma list_map_autoref_isSng[autoref_rules]:
"(list_map_isSng, op_map_isSng) ∈ ⟨Rk,Rv⟩list_map_rel → bool_rel"
unfolding list_map_rel_def
by (blast dest!: param_list_map_isSng list_map_autoref_isSng_aux)
lemma list_map_autoref_size_aux:
assumes "distinct (map fst x)"
shows "card (dom (map_of x)) = length x"
proof-
have "card (dom (map_of x)) = card (map_to_set (map_of x))"
by (simp add: card_map_to_set)
also from assms have "... = card (set x)"
by (simp add: map_to_set_map_of)
also from assms have "... = length x"
by (force simp: distinct_card dest!: distinct_mapI)
finally show ?thesis .
qed
lemma param_list_map_size[param]:
"(list_map_size, list_map_size) ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → nat_rel"
unfolding list_map_size_def[abs_def] by parametricity
lemma list_map_autoref_size[autoref_rules]:
shows "(list_map_size, op_map_size) ∈
⟨Rk,Rv⟩list_map_rel → nat_rel"
unfolding list_map_size_def[abs_def] op_map_size_def[abs_def]
list_map_rel_def br_def list_map_invar_def
by (force simp: list_map_autoref_size_aux list_rel_imp_same_length)
lemma autoref_list_map_is_iterator[autoref_ga_rules]:
shows "is_map_to_list Rk Rv list_map_rel list_map_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
fix l m'
assume "(l,m') ∈ ⟨Rk,Rv⟩list_map_rel"
then obtain l' where *: "(l,l')∈⟨⟨Rk,Rv⟩prod_rel⟩list_rel" "(l',m')∈br map_of list_map_invar"
unfolding list_map_rel_def by blast
then have "RETURN l' ≤ it_to_sorted_list (key_rel (λ_ _. True)) (map_to_set m')"
unfolding it_to_sorted_list_def
apply (intro refine_vcg)
unfolding br_def list_map_invar_def key_rel_def[abs_def]
apply (auto intro: distinct_mapI simp: map_to_set_map_of)
done
with * show
"∃l'. (list_map_to_list l, l') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel ∧
RETURN l' ≤ it_to_sorted_list (key_rel (λ_ _. True))
(map_to_set m')"
unfolding list_map_to_list_def by force
qed
lemma pi_list_map[icf_proper_iteratorI]:
"proper_it (list_map_iteratei m) (list_map_iteratei m)"
unfolding proper_it_def list_map_iteratei_def by blast
lemma pi'_list_map[icf_proper_iteratorI]:
"proper_it' list_map_iteratei list_map_iteratei"
by (rule proper_it'I, rule pi_list_map)
primrec list_map_pick_remove where
"list_map_pick_remove [] = undefined"
| "list_map_pick_remove (kv#l) = (kv,l)"
context begin interpretation autoref_syn .
lemma list_map_autoref_pick_remove[autoref_rules]:
assumes NE: "SIDE_PRECOND (m≠Map.empty)"
assumes R: "(l,m)∈⟨Rk,Rv⟩list_map_rel"
defines "Rres ≡ ⟨(Rk×⇩rRv) ×⇩r ⟨Rk,Rv⟩list_map_rel⟩nres_rel"
shows "(
RETURN (list_map_pick_remove l),
(OP op_map_pick_remove ::: ⟨Rk,Rv⟩list_map_rel → Rres)$m
) ∈ Rres"
proof -
from NE R obtain k v lr where
[simp]: "l=(k,v)#lr"
by (cases l) (auto simp: list_map_rel_def br_def)
thm list_map_rel_def
from R obtain l' where
LL': "(l,l')∈⟨Rk×⇩rRv⟩list_rel" and
L'M: "(l',m)∈br map_of list_map_invar"
unfolding list_map_rel_def by auto
from LL' obtain k' v' lr' where
[simp]: "l' = (k',v')#lr'" and
KVR: "(k,k')∈Rk" "(v,v')∈Rv" and
LRR: "(lr,lr')∈⟨Rk×⇩rRv⟩list_rel"
by (fastforce elim!: list_relE)
from L'M have
MKV': "m k' = Some v'" and
LRR': "(lr',m|`(-{k'}))∈br map_of list_map_invar"
by (auto
simp: restrict_map_def map_of_eq_None_iff br_def list_map_invar_def
intro!: ext
intro: sym)
from LRR LRR' have LM: "(lr,m|`(-{k'}))∈⟨Rk,Rv⟩list_map_rel"
unfolding list_map_rel_def by auto
show ?thesis
apply (simp add: Rres_def)
apply (refine_rcg SPEC_refine nres_relI refine_vcg)
using LM KVR MKV'
by auto
qed
end
end
Theory Impl_Array_Hash_Map
section ‹\isaheader{Array Based Hash-Maps}›
theory Impl_Array_Hash_Map imports
Automatic_Refinement.Automatic_Refinement
"../../Iterator/Array_Iterator"
"../Gen/Gen_Map"
"../Intf/Intf_Hash"
"../Intf/Intf_Map"
"../../Lib/HashCode"
"../../Lib/Code_Target_ICF"
"../../Lib/Diff_Array"
Impl_List_Map
begin
subsection ‹Type definition and primitive operations›
definition load_factor :: nat
where "load_factor = 75"
datatype ('key, 'val) hashmap =
HashMap "('key,'val) list_map array" "nat"
subsection ‹Operations›
definition new_hashmap_with :: "nat ⇒ ('k, 'v) hashmap"
where "⋀size. new_hashmap_with size =
HashMap (new_array [] size) 0"
definition ahm_empty :: "nat ⇒ ('k, 'v) hashmap"
where "ahm_empty def_size ≡ new_hashmap_with def_size"
definition bucket_ok :: "'k bhc ⇒ nat ⇒ nat ⇒ ('k×'v) list ⇒ bool"
where "bucket_ok bhc len h kvs = (∀k ∈ fst ` set kvs. bhc len k = h)"
definition ahm_invar_aux :: "'k bhc ⇒ nat ⇒ ('k×'v) list array ⇒ bool"
where
"ahm_invar_aux bhc n a ⟷
(∀h. h < array_length a ⟶ bucket_ok bhc (array_length a) h
(array_get a h) ∧ list_map_invar (array_get a h)) ∧
array_foldl (λ_ n kvs. n + size kvs) 0 a = n ∧
array_length a > 1"
primrec ahm_invar :: "'k bhc ⇒ ('k, 'v) hashmap ⇒ bool"
where "ahm_invar bhc (HashMap a n) = ahm_invar_aux bhc n a"
definition ahm_lookup_aux :: "'k eq ⇒ 'k bhc ⇒
'k ⇒ ('k, 'v) list_map array ⇒ 'v option"
where [simp]: "ahm_lookup_aux eq bhc k a = list_map_lookup eq k (array_get a (bhc (array_length a) k))"
primrec ahm_lookup where
"ahm_lookup eq bhc k (HashMap a _) = ahm_lookup_aux eq bhc k a"
definition "ahm_α bhc m ≡ λk. ahm_lookup (=) bhc k m"
definition ahm_map_rel_def_internal:
"ahm_map_rel Rk Rv ≡ {(HashMap a n, HashMap a' n)| a a' n n'.
(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel ∧ (n,n') ∈ Id}"
lemma ahm_map_rel_def: "⟨Rk,Rv⟩ ahm_map_rel ≡
{(HashMap a n, HashMap a' n)| a a' n n'.
(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel ∧ (n,n') ∈ Id}"
unfolding relAPP_def ahm_map_rel_def_internal .
definition ahm_map_rel'_def:
"ahm_map_rel' bhc ≡ br (ahm_α bhc) (ahm_invar bhc)"
definition ahm_rel_def_internal: "ahm_rel bhc Rk Rv =
⟨Rk,Rv⟩ ahm_map_rel O ahm_map_rel' (abstract_bounded_hashcode Rk bhc)"
lemma ahm_rel_def: "⟨Rk, Rv⟩ ahm_rel bhc ≡
⟨Rk,Rv⟩ ahm_map_rel O ahm_map_rel' (abstract_bounded_hashcode Rk bhc)"
unfolding relAPP_def ahm_rel_def_internal .
lemmas [autoref_rel_intf] = REL_INTFI[of "ahm_rel bhc" i_map] for bhc
abbreviation "dflt_ahm_rel ≡ ahm_rel bounded_hashcode_nat"
primrec ahm_iteratei_aux :: "(('k×'v) list array) ⇒ ('k×'v, 'σ) set_iterator"
where "ahm_iteratei_aux (Array xs) c f = foldli (concat xs) c f"
primrec ahm_iteratei :: "(('k, 'v) hashmap) ⇒ (('k×'v), 'σ) set_iterator"
where
"ahm_iteratei (HashMap a n) = ahm_iteratei_aux a"
definition ahm_rehash_aux' :: "'k bhc ⇒ nat ⇒ 'k×'v ⇒
('k×'v) list array ⇒ ('k×'v) list array"
where
"ahm_rehash_aux' bhc n kv a =
(let h = bhc n (fst kv)
in array_set a h (kv # array_get a h))"
definition ahm_rehash_aux :: "'k bhc ⇒ ('k×'v) list array ⇒ nat ⇒
('k×'v) list array"
where
"ahm_rehash_aux bhc a sz = ahm_iteratei_aux a (λx. True)
(ahm_rehash_aux' bhc sz) (new_array [] sz)"
primrec ahm_rehash :: "'k bhc ⇒ ('k,'v) hashmap ⇒ nat ⇒ ('k,'v) hashmap"
where "ahm_rehash bhc (HashMap a n) sz = HashMap (ahm_rehash_aux bhc a sz) n"
primrec hm_grow :: "('k,'v) hashmap ⇒ nat"
where "hm_grow (HashMap a n) = 2 * array_length a + 3"
primrec ahm_filled :: "('k,'v) hashmap ⇒ bool"
where "ahm_filled (HashMap a n) = (array_length a * load_factor ≤ n * 100)"
primrec ahm_update_aux :: "'k eq ⇒ 'k bhc ⇒ ('k,'v) hashmap ⇒
'k ⇒ 'v ⇒ ('k, 'v) hashmap"
where
"ahm_update_aux eq bhc (HashMap a n) k v =
(let h = bhc (array_length a) k;
m = array_get a h;
insert = list_map_lookup eq k m = None
in HashMap (array_set a h (list_map_update eq k v m))
(if insert then n + 1 else n))"
definition ahm_update :: "'k eq ⇒ 'k bhc ⇒ 'k ⇒ 'v ⇒
('k, 'v) hashmap ⇒ ('k, 'v) hashmap"
where
"ahm_update eq bhc k v hm =
(let hm' = ahm_update_aux eq bhc hm k v
in (if ahm_filled hm' then ahm_rehash bhc hm' (hm_grow hm') else hm'))"
primrec ahm_delete :: "'k eq ⇒ 'k bhc ⇒ 'k ⇒
('k,'v) hashmap ⇒ ('k,'v) hashmap"
where
"ahm_delete eq bhc k (HashMap a n) =
(let h = bhc (array_length a) k;
m = array_get a h;
deleted = (list_map_lookup eq k m ≠ None)
in HashMap (array_set a h (list_map_delete eq k m)) (if deleted then n - 1 else n))"
primrec ahm_isEmpty :: "('k,'v) hashmap ⇒ bool" where
"ahm_isEmpty (HashMap _ n) = (n = 0)"
primrec ahm_isSng :: "('k,'v) hashmap ⇒ bool" where
"ahm_isSng (HashMap _ n) = (n = 1)"
primrec ahm_size :: "('k,'v) hashmap ⇒ nat" where
"ahm_size (HashMap _ n) = n"
lemma hm_grow_gt_1 [iff]:
"Suc 0 < hm_grow hm"
by(cases hm)(simp)
lemma bucket_ok_Nil [simp]: "bucket_ok bhc len h [] = True"
by(simp add: bucket_ok_def)
lemma bucket_okD:
"⟦ bucket_ok bhc len h xs; (k, v) ∈ set xs ⟧
⟹ bhc len k = h"
by(auto simp add: bucket_ok_def)
lemma bucket_okI:
"(⋀k. k ∈ fst ` set kvs ⟹ bhc len k = h) ⟹ bucket_ok bhc len h kvs"
by(simp add: bucket_ok_def)
subsection ‹Parametricity›
lemma param_HashMap[param]: "(HashMap, HashMap) ∈
⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel → nat_rel → ⟨Rk,Rv⟩ahm_map_rel"
unfolding ahm_map_rel_def by force
lemma param_case_hashmap[param]: "(case_hashmap, case_hashmap) ∈
(⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel → nat_rel → R) →
⟨Rk,Rv⟩ahm_map_rel → R"
unfolding ahm_map_rel_def[abs_def]
by (force split: hashmap.split dest: fun_relD)
lemma rec_hashmap_is_case[simp]: "rec_hashmap = case_hashmap"
by (intro ext, simp split: hashmap.split)
subsection ‹@{term ahm_invar}›
lemma ahm_invar_auxD:
assumes "ahm_invar_aux bhc n a"
shows "⋀h. h < array_length a ⟹
bucket_ok bhc (array_length a) h (array_get a h)" and
"⋀h. h < array_length a ⟹
list_map_invar (array_get a h)" and
"n = array_foldl (λ_ n kvs. n + length kvs) 0 a" and
"array_length a > 1"
using assms unfolding ahm_invar_aux_def by auto
lemma ahm_invar_auxE:
assumes "ahm_invar_aux bhc n a"
obtains "∀h. h < array_length a ⟶
bucket_ok bhc (array_length a) h (array_get a h) ∧
list_map_invar (array_get a h)" and
"n = array_foldl (λ_ n kvs. n + length kvs) 0 a" and
"array_length a > 1"
using assms unfolding ahm_invar_aux_def by blast
lemma ahm_invar_auxI:
"⟦ ⋀h. h < array_length a ⟹
bucket_ok bhc (array_length a) h (array_get a h);
⋀h. h < array_length a ⟹ list_map_invar (array_get a h);
n = array_foldl (λ_ n kvs. n + length kvs) 0 a; array_length a > 1 ⟧
⟹ ahm_invar_aux bhc n a"
unfolding ahm_invar_aux_def by blast
lemma ahm_invar_distinct_fst_concatD:
assumes inv: "ahm_invar_aux bhc n (Array xs)"
shows "distinct (map fst (concat xs))"
proof -
{ fix h
assume "h < length xs"
with inv have "bucket_ok bhc (length xs) h (xs ! h)" and
"list_map_invar (xs ! h)"
by(simp_all add: ahm_invar_aux_def) }
note no_junk = this
show ?thesis unfolding map_concat
proof(rule distinct_concat')
have "distinct [x←xs . x ≠ []]" unfolding distinct_conv_nth
proof(intro allI ballI impI)
fix i j
assume "i < length [x←xs . x ≠ []]" "j < length [x←xs . x ≠ []]" "i ≠ j"
from filter_nth_ex_nth[OF ‹i < length [x←xs . x ≠ []]›]
obtain i' where "i' ≥ i" "i' < length xs" and ith: "[x←xs . x ≠ []] ! i = xs ! i'"
and eqi: "[x←take i' xs . x ≠ []] = take i [x←xs . x ≠ []]" by blast
from filter_nth_ex_nth[OF ‹j < length [x←xs . x ≠ []]›]
obtain j' where "j' ≥ j" "j' < length xs" and jth: "[x←xs . x ≠ []] ! j = xs ! j'"
and eqj: "[x←take j' xs . x ≠ []] = take j [x←xs . x ≠ []]" by blast
show "[x←xs . x ≠ []] ! i ≠ [x←xs . x ≠ []] ! j"
proof
assume "[x←xs . x ≠ []] ! i = [x←xs . x ≠ []] ! j"
hence eq: "xs ! i' = xs ! j'" using ith jth by simp
from ‹i < length [x←xs . x ≠ []]›
have "[x←xs . x ≠ []] ! i ∈ set [x←xs . x ≠ []]" by(rule nth_mem)
with ith have "xs ! i' ≠ []" by simp
then obtain kv where "kv ∈ set (xs ! i')" by(fastforce simp add: neq_Nil_conv)
with no_junk[OF ‹i' < length xs›] have "bhc (length xs) (fst kv) = i'"
by(simp add: bucket_ok_def)
moreover from eq ‹kv ∈ set (xs ! i')› have "kv ∈ set (xs ! j')" by simp
with no_junk[OF ‹j' < length xs›] have "bhc (length xs) (fst kv) = j'"
by(simp add: bucket_ok_def)
ultimately have [simp]: "i' = j'" by simp
from ‹i < length [x←xs . x ≠ []]› have "i = length (take i [x←xs . x ≠ []])" by simp
also from eqi eqj have "take i [x←xs . x ≠ []] = take j [x←xs . x ≠ []]" by simp
finally show False using ‹i ≠ j› ‹j < length [x←xs . x ≠ []]› by simp
qed
qed
moreover have "inj_on (map fst) {x ∈ set xs. x ≠ []}"
proof(rule inj_onI)
fix x y
assume "x ∈ {x ∈ set xs. x ≠ []}" "y ∈ {x ∈ set xs. x ≠ []}" "map fst x = map fst y"
hence "x ∈ set xs" "y ∈ set xs" "x ≠ []" "y ≠ []" by auto
from ‹x ∈ set xs› obtain i where "xs ! i = x" "i < length xs" unfolding set_conv_nth by fastforce
from ‹y ∈ set xs› obtain j where "xs ! j = y" "j < length xs" unfolding set_conv_nth by fastforce
from ‹x ≠ []› obtain k v x' where "x = (k, v) # x'" by(cases x) auto
with no_junk[OF ‹i < length xs›] ‹xs ! i = x›
have "bhc (length xs) k = i" by(auto simp add: bucket_ok_def)
moreover from ‹map fst x = map fst y› ‹x = (k, v) # x'› obtain v' where "(k, v') ∈ set y" by fastforce
with no_junk[OF ‹j < length xs›] ‹xs ! j = y›
have "bhc (length xs) k = j" by(auto simp add: bucket_ok_def)
ultimately have "i = j" by simp
with ‹xs ! i = x› ‹xs ! j = y› show "x = y" by simp
qed
ultimately show "distinct [ys←map (map fst) xs . ys ≠ []]"
by(simp add: filter_map o_def distinct_map)
next
fix ys
have A: "⋀xs. distinct (map fst xs) = list_map_invar xs"
by (simp add: list_map_invar_def)
assume "ys ∈ set (map (map fst) xs)"
thus "distinct ys"
by(clarsimp simp add: set_conv_nth A) (erule no_junk(2))
next
fix ys zs
assume "ys ∈ set (map (map fst) xs)" "zs ∈ set (map (map fst) xs)" "ys ≠ zs"
then obtain ys' zs' where [simp]: "ys = map fst ys'" "zs = map fst zs'"
and "ys' ∈ set xs" "zs' ∈ set xs" by auto
have "fst ` set ys' ∩ fst ` set zs' = {}"
proof(rule equals0I)
fix k
assume "k ∈ fst ` set ys' ∩ fst ` set zs'"
then obtain v v' where "(k, v) ∈ set ys'" "(k, v') ∈ set zs'" by(auto)
from ‹ys' ∈ set xs› obtain i where "xs ! i = ys'" "i < length xs" unfolding set_conv_nth by fastforce
with ‹(k, v) ∈ set ys'› have "bhc (length xs) k = i" by(auto dest: no_junk bucket_okD)
moreover
from ‹zs' ∈ set xs› obtain j where "xs ! j = zs'" "j < length xs" unfolding set_conv_nth by fastforce
with ‹(k, v') ∈ set zs'› have "bhc (length xs) k = j" by(auto dest: no_junk bucket_okD)
ultimately have "i = j" by simp
with ‹xs ! i = ys'› ‹xs ! j = zs'› have "ys' = zs'" by simp
with ‹ys ≠ zs› show False by simp
qed
thus "set ys ∩ set zs = {}" by simp
qed
qed
subsection ‹@{term "ahm_α"}›
lemma list_map_lookup_is_map_of:
"list_map_lookup (=) k l = map_of l k"
using list_map_autoref_lookup_aux[where eq="(=)" and
Rk=Id and Rv=Id] by force
definition "ahm_α_aux bhc a ≡
(λk. ahm_lookup_aux (=) bhc k a)"
lemma ahm_α_aux_def2: "ahm_α_aux bhc a = (λk. map_of (array_get a
(bhc (array_length a) k)) k)"
unfolding ahm_α_aux_def ahm_lookup_aux_def
by (simp add: list_map_lookup_is_map_of)
lemma ahm_α_def2: "ahm_α bhc (HashMap a n) = ahm_α_aux bhc a"
unfolding ahm_α_def ahm_α_aux_def by simp
lemma finite_dom_ahm_α_aux:
assumes "is_bounded_hashcode Id (=) bhc" "ahm_invar_aux bhc n a"
shows "finite (dom (ahm_α_aux bhc a))"
proof -
have "dom (ahm_α_aux bhc a) ⊆ (⋃h ∈ range (bhc (array_length a) :: 'a ⇒ nat). dom (map_of (array_get a h)))"
unfolding ahm_α_aux_def2
by(force simp add: dom_map_of_conv_image_fst dest: map_of_SomeD)
moreover have "finite …"
proof(rule finite_UN_I)
from ‹ahm_invar_aux bhc n a› have "array_length a > 1" by(simp add: ahm_invar_aux_def)
hence "range (bhc (array_length a) :: 'a ⇒ nat) ⊆ {0..<array_length a}"
using assms by force
thus "finite (range (bhc (array_length a) :: 'a ⇒ nat))"
by(rule finite_subset) simp
qed(rule finite_dom_map_of)
ultimately show ?thesis by(rule finite_subset)
qed
lemma ahm_α_aux_new_array[simp]:
assumes bhc: "is_bounded_hashcode Id (=) bhc" "1 < sz"
shows "ahm_α_aux bhc (new_array [] sz) k = None"
using is_bounded_hashcodeD(3)[OF assms]
unfolding ahm_α_aux_def ahm_lookup_aux_def by simp
lemma ahm_α_aux_conv_map_of_concat:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
assumes inv: "ahm_invar_aux bhc n (Array xs)"
shows "ahm_α_aux bhc (Array xs) = map_of (concat xs)"
proof
fix k
show "ahm_α_aux bhc (Array xs) k = map_of (concat xs) k"
proof(cases "map_of (concat xs) k")
case None
hence "k ∉ fst ` set (concat xs)" by(simp add: map_of_eq_None_iff)
hence "k ∉ fst ` set (xs ! bhc (length xs) k)"
proof(rule contrapos_nn)
assume "k ∈ fst ` set (xs ! bhc (length xs) k)"
then obtain v where "(k, v) ∈ set (xs ! bhc (length xs) k)" by auto
moreover from inv have "bhc (length xs) k < length xs"
using bhc by (force simp: ahm_invar_aux_def)
ultimately show "k ∈ fst ` set (concat xs)"
by (force intro: rev_image_eqI)
qed
thus ?thesis unfolding None ahm_α_aux_def2
by (simp add: map_of_eq_None_iff)
next
case (Some v)
hence "(k, v) ∈ set (concat xs)" by(rule map_of_SomeD)
then obtain ys where "ys ∈ set xs" "(k, v) ∈ set ys"
unfolding set_concat by blast
from ‹ys ∈ set xs› obtain i j where "i < length xs" "xs ! i = ys"
unfolding set_conv_nth by auto
with inv ‹(k, v) ∈ set ys›
show ?thesis unfolding Some
unfolding ahm_α_aux_def2
by(force dest: bucket_okD simp add: ahm_invar_aux_def list_map_invar_def)
qed
qed
lemma ahm_invar_aux_card_dom_ahm_α_auxD:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
assumes inv: "ahm_invar_aux bhc n a"
shows "card (dom (ahm_α_aux bhc a)) = n"
proof(cases a)
case [simp]: (Array xs)
from inv have "card (dom (ahm_α_aux bhc (Array xs))) = card (dom (map_of (concat xs)))"
by(simp add: ahm_α_aux_conv_map_of_concat[OF bhc])
also from inv have "distinct (map fst (concat xs))"
by(simp add: ahm_invar_distinct_fst_concatD)
hence "card (dom (map_of (concat xs))) = length (concat xs)"
by(rule card_dom_map_of)
also have "length (concat xs) = foldl (+) 0 (map length xs)"
by (simp add: length_concat foldl_conv_fold add.commute fold_plus_sum_list_rev)
also from inv
have "… = n" unfolding foldl_map by(simp add: ahm_invar_aux_def array_foldl_foldl)
finally show ?thesis by(simp)
qed
lemma finite_dom_ahm_α:
assumes "is_bounded_hashcode Id (=) bhc" "ahm_invar bhc hm"
shows "finite (dom (ahm_α bhc hm))"
using assms by (cases hm, force intro: finite_dom_ahm_α_aux
simp: ahm_α_def2)
subsection ‹@{term ahm_empty}›
lemma ahm_invar_aux_new_array:
assumes "n > 1"
shows "ahm_invar_aux bhc 0 (new_array [] n)"
proof -
have "foldl (λb (k, v). b + length v) 0 (zip [0..<n] (replicate n [])) = 0"
by(induct n)(simp_all add: replicate_Suc_conv_snoc del: replicate_Suc)
with assms show ?thesis by(simp add: ahm_invar_aux_def array_foldl_new_array list_map_invar_def)
qed
lemma ahm_invar_new_hashmap_with:
"n > 1 ⟹ ahm_invar bhc (new_hashmap_with n)"
by(auto simp add: ahm_invar_def new_hashmap_with_def intro: ahm_invar_aux_new_array)
lemma ahm_α_new_hashmap_with:
assumes "is_bounded_hashcode Id (=) bhc" and "n > 1"
shows "Map.empty = ahm_α bhc (new_hashmap_with n)"
unfolding new_hashmap_with_def ahm_α_def
using is_bounded_hashcodeD(3)[OF assms] by force
lemma ahm_empty_impl:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
assumes def_size: "def_size > 1"
shows "(ahm_empty def_size, Map.empty) ∈ ahm_map_rel' bhc"
proof-
from def_size and ahm_α_new_hashmap_with[OF bhc def_size] and
ahm_invar_new_hashmap_with[OF def_size]
show ?thesis unfolding ahm_empty_def ahm_map_rel'_def br_def by force
qed
lemma param_ahm_empty[param]:
assumes def_size: "(def_size, def_size') ∈ nat_rel"
shows "(ahm_empty def_size ,ahm_empty def_size') ∈
⟨Rk,Rv⟩ahm_map_rel"
unfolding ahm_empty_def[abs_def] new_hashmap_with_def[abs_def]
new_array_def[abs_def]
using assms by parametricity
lemma autoref_ahm_empty[autoref_rules]:
fixes Rk :: "('kc×'ka) set"
assumes bhc: "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
assumes def_size: "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('kc) def_size)"
shows "(ahm_empty def_size, op_map_empty) ∈ ⟨Rk, Rv⟩ahm_rel bhc"
proof-
from bhc have eq': "(eq,(=)) ∈ Rk → Rk → bool_rel"
by (simp add: is_bounded_hashcodeD)
with bhc have "is_bounded_hashcode Id (=)
(abstract_bounded_hashcode Rk bhc)"
unfolding autoref_tag_defs
by blast
thus ?thesis using assms
unfolding op_map_empty_def
unfolding ahm_rel_def is_valid_def_hm_size_def autoref_tag_defs
apply (intro relcompI)
apply (rule param_ahm_empty[of def_size def_size], simp)
apply (blast intro: ahm_empty_impl)
done
qed
subsection ‹@{term "ahm_lookup"}›
lemma param_ahm_lookup[param]:
assumes bhc: "is_bounded_hashcode Rk eq bhc"
defines bhc'_def: "bhc' ≡ abstract_bounded_hashcode Rk bhc"
assumes inv: "ahm_invar bhc' m'"
assumes K: "(k,k') ∈ Rk"
assumes M: "(m,m') ∈ ⟨Rk,Rv⟩ahm_map_rel"
shows "(ahm_lookup eq bhc k m, ahm_lookup (=) bhc' k' m') ∈
⟨Rv⟩option_rel"
proof-
from bhc have eq': "(eq,(=)) ∈ Rk → Rk → bool_rel" by (simp add: is_bounded_hashcodeD)
moreover from abstract_bhc_correct[OF bhc]
have bhc': "(bhc,bhc') ∈ nat_rel → Rk → nat_rel" unfolding bhc'_def .
moreover from M obtain a a' n n' where
[simp]: "m = HashMap a n" and [simp]: "m' = HashMap a' n'" and
A: "(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel" and N: "(n,n') ∈ Id"
by (cases m, cases m', unfold ahm_map_rel_def, auto)
moreover from inv and array_rel_imp_same_length[OF A]
have "array_length a > 1" by (simp add: ahm_invar_aux_def)
with abstract_bhc_is_bhc[OF bhc]
have "bhc' (array_length a) k' < array_length a"
unfolding bhc'_def by blast
with bhc'[param_fo, OF _ K]
have "bhc (array_length a) k < array_length a" by simp
ultimately show ?thesis using K
unfolding ahm_lookup_def[abs_def] rec_hashmap_is_case
by (simp, parametricity)
qed
lemma ahm_lookup_impl:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
shows "(ahm_lookup (=) bhc, op_map_lookup) ∈ Id → ahm_map_rel' bhc → Id"
unfolding ahm_map_rel'_def br_def ahm_α_def by force
lemma autoref_ahm_lookup[autoref_rules]:
assumes
bhc[unfolded autoref_tag_defs]: "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
shows "(ahm_lookup eq bhc, op_map_lookup)
∈ Rk → ⟨Rk,Rv⟩ahm_rel bhc → ⟨Rv⟩option_rel"
proof (intro fun_relI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix k k' a m'
assume K: "(k,k') ∈ Rk"
assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'"
by blast
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
hence inv: "ahm_invar ?bhc' a'"
unfolding ahm_map_rel'_def br_def by simp
from relcompI[OF param_ahm_lookup[OF bhc inv K M1]
ahm_lookup_impl[param_fo, OF bhc' _ M2]]
show "(ahm_lookup eq bhc k a, op_map_lookup k' m') ∈ ⟨Rv⟩option_rel"
by simp
qed
subsection ‹@{term "ahm_iteratei"}›
abbreviation "ahm_to_list ≡ it_to_list ahm_iteratei"
lemma param_ahm_iteratei_aux[param]:
"(ahm_iteratei_aux,ahm_iteratei_aux) ∈ ⟨⟨Ra⟩list_rel⟩array_rel →
(Rb → bool_rel) → (Ra → Rb → Rb) → Rb → Rb"
unfolding ahm_iteratei_aux_def[abs_def] by parametricity
lemma param_ahm_iteratei[param]:
"(ahm_iteratei,ahm_iteratei) ∈ ⟨Rk,Rv⟩ahm_map_rel →
(Rb → bool_rel) → (⟨Rk,Rv⟩prod_rel → Rb → Rb) → Rb → Rb"
unfolding ahm_iteratei_def[abs_def] rec_hashmap_is_case by parametricity
lemma param_ahm_to_list[param]:
"(ahm_to_list,ahm_to_list) ∈
⟨Rk, Rv⟩ahm_map_rel → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
unfolding it_to_list_def[abs_def] by parametricity
lemma ahm_to_list_distinct[simp,intro]:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
assumes inv: "ahm_invar bhc m"
shows "distinct (ahm_to_list m)"
proof-
obtain n a where [simp]: "m = HashMap a n" by (cases m)
obtain l where [simp]: "a = Array l" by (cases a)
from inv show "distinct (ahm_to_list m)" unfolding it_to_list_def
by (force intro: distinct_mapI dest: ahm_invar_distinct_fst_concatD)
qed
lemma set_ahm_to_list:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
assumes ref: "(m,m') ∈ ahm_map_rel' bhc"
shows "map_to_set m' = set (ahm_to_list m)"
proof-
obtain n a where [simp]: "m = HashMap a n" by (cases m)
obtain l where [simp]: "a = Array l" by (cases a)
from ref have α[simp]: "m' = ahm_α bhc m" and
inv: "ahm_invar bhc m"
unfolding ahm_map_rel'_def br_def by auto
from inv have length: "length l > 1"
unfolding ahm_invar_def ahm_invar_aux_def by force
from inv have buckets_ok: "⋀h x. h < length l ⟹ x ∈ set (l!h) ⟹
bhc (length l) (fst x) = h"
"⋀h. h < length l ⟹ distinct (map fst (l!h))"
by (simp_all add: ahm_invar_def ahm_invar_aux_def
bucket_ok_def list_map_invar_def)
show ?thesis unfolding it_to_list_def α ahm_α_def ahm_iteratei_def
apply (simp add: list_map_lookup_is_map_of)
proof (intro equalityI subsetI, goal_cases)
case prems: (1 x)
let ?m = "λk. map_of (l ! bhc (length l) k) k"
obtain k v where [simp]: "x = (k, v)" by (cases x)
from prems have "set_to_map (map_to_set ?m) k = Some v"
by (simp add: set_to_map_simp inj_on_fst_map_to_set)
also note map_to_set_inverse
finally have "map_of (l ! bhc (length l) k) k = Some v" .
hence "(k,v) ∈ set (l ! bhc (length l) k)"
by (simp add: map_of_SomeD)
moreover have "bhc (length l) k < length l" using bhc length ..
ultimately show ?case by force
next
case prems: (2 x)
obtain k v where [simp]: "x = (k, v)" by (cases x)
from prems obtain h where h_props: "(k,v) ∈ set (l!h)" "h < length l"
by (force simp: set_conv_nth)
moreover from h_props and buckets_ok
have "bhc (length l) k = h" "distinct (map fst (l!h))" by auto
ultimately have "map_of (l ! bhc (length l) k) k = Some v"
by (force intro: map_of_is_SomeI)
thus ?case by simp
qed
qed
lemma ahm_iteratei_aux_impl:
assumes inv: "ahm_invar_aux bhc n a"
and bhc: "is_bounded_hashcode Id (=) bhc"
shows "map_iterator (ahm_iteratei_aux a) (ahm_α_aux bhc a)"
proof (cases a, rule)
fix xs assume [simp]: "a = Array xs"
show "ahm_iteratei_aux a = foldli (concat xs)"
by (intro ext, simp)
from ahm_invar_distinct_fst_concatD and inv
show "distinct (map fst (concat xs))" by simp
from ahm_α_aux_conv_map_of_concat and assms
show "ahm_α_aux bhc a = map_of (concat xs)" by simp
qed
lemma ahm_iteratei_impl:
assumes inv: "ahm_invar bhc m"
and bhc: "is_bounded_hashcode Id (=) bhc"
shows "map_iterator (ahm_iteratei m) (ahm_α bhc m)"
by (insert assms, cases m, simp add: ahm_α_def2,
erule (1) ahm_iteratei_aux_impl)
lemma autoref_ahm_is_iterator[autoref_ga_rules]:
assumes bhc: "GEN_ALGO_tag (is_bounded_hashcode Rk eq bhc)"
shows "is_map_to_list Rk Rv (ahm_rel bhc) ahm_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (intro allI impI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix a m' assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'"
unfolding autoref_tag_defs
apply (rule_tac abstract_bhc_is_bhc)
by simp_all
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
hence inv: "ahm_invar ?bhc' a'"
unfolding ahm_map_rel'_def br_def by simp
let ?l' = "ahm_to_list a'"
from param_ahm_to_list[param_fo, OF M1]
have "(ahm_to_list a, ?l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel" .
moreover from ahm_to_list_distinct[OF bhc' inv]
have "distinct (ahm_to_list a')" .
moreover from set_ahm_to_list[OF bhc' M2]
have "map_to_set m' = set (ahm_to_list a')" .
ultimately show "∃l'. (ahm_to_list a, l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel ∧
RETURN l' ≤ it_to_sorted_list
(key_rel (λ_ _. True)) (map_to_set m')"
by (force simp: it_to_sorted_list_def key_rel_def[abs_def])
qed
lemma ahm_iteratei_aux_code[code]:
"ahm_iteratei_aux a c f σ = idx_iteratei array_get array_length a c
(λx. foldli x c f) σ"
proof(cases a)
case [simp]: (Array xs)
have "ahm_iteratei_aux a c f σ = foldli (concat xs) c f σ" by simp
also have "… = foldli xs c (λx. foldli x c f) σ" by (simp add: foldli_concat)
also have "… = idx_iteratei (!) length xs c (λx. foldli x c f) σ"
by (simp add: idx_iteratei_nth_length_conv_foldli)
also have "… = idx_iteratei array_get array_length a c (λx. foldli x c f) σ"
by(simp add: idx_iteratei_array_get_Array_conv_nth)
finally show ?thesis .
qed
subsection ‹@{term "ahm_rehash"}›
lemma array_length_ahm_rehash_aux':
"array_length (ahm_rehash_aux' bhc n kv a) = array_length a"
by(simp add: ahm_rehash_aux'_def Let_def)
lemma ahm_rehash_aux'_preserves_ahm_invar_aux:
assumes inv: "ahm_invar_aux bhc n a"
and bhc: "is_bounded_hashcode Id (=) bhc"
and fresh: "k ∉ fst ` set (array_get a (bhc (array_length a) k))"
shows "ahm_invar_aux bhc (Suc n) (ahm_rehash_aux' bhc (array_length a) (k, v) a)"
(is "ahm_invar_aux bhc _ ?a")
proof(rule ahm_invar_auxI)
note invD = ahm_invar_auxD[OF inv]
let ?l = "array_length a"
fix h
assume "h < array_length ?a"
hence hlen: "h < ?l" by(simp add: array_length_ahm_rehash_aux')
from invD(1,2)[OF this] have bucket: "bucket_ok bhc ?l h (array_get a h)"
and dist: "distinct (map fst (array_get a h))"
by (simp_all add: list_map_invar_def)
let ?h = "bhc (array_length a) k"
from hlen bucket show "bucket_ok bhc (array_length ?a) h (array_get ?a h)"
by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_length_ahm_rehash_aux' array_get_array_set_other dest: bucket_okD intro!: bucket_okI)
from dist hlen fresh
show "list_map_invar (array_get ?a h)"
unfolding list_map_invar_def
by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_get_array_set_other)
next
let ?f = "λn kvs. n + length kvs"
{ fix n :: nat and xs :: "('a × 'b) list list"
have "foldl ?f n xs = n + foldl ?f 0 xs"
by(induct xs arbitrary: rule: rev_induct) simp_all }
note fold = this
let ?h = "bhc (array_length a) k"
obtain xs where a [simp]: "a = Array xs" by(cases a)
from inv and bhc have [simp]: "bhc (length xs) k < length xs"
by (force simp add: ahm_invar_aux_def)
have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
by(auto elim: ahm_invar_auxE)
hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
thus "Suc n = array_foldl (λ_ n kvs. n + length kvs) 0 ?a"
by(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update)(subst (1 2 3 4) fold, simp)
next
from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
thus "1 < array_length ?a" by(simp add: array_length_ahm_rehash_aux')
qed
lemma ahm_rehash_aux_correct:
fixes a :: "('k×'v) list array"
assumes bhc: "is_bounded_hashcode Id (=) bhc"
and inv: "ahm_invar_aux bhc n a"
and "sz > 1"
shows "ahm_invar_aux bhc n (ahm_rehash_aux bhc a sz)" (is "?thesis1")
and "ahm_α_aux bhc (ahm_rehash_aux bhc a sz) = ahm_α_aux bhc a" (is "?thesis2")
proof -
let ?a = "ahm_rehash_aux bhc a sz"
define I where "I it a' ⟷
ahm_invar_aux bhc (n - card it) a'
∧ array_length a' = sz
∧ (∀k. if k ∈ it then
ahm_α_aux bhc a' k = None
else ahm_α_aux bhc a' k = ahm_α_aux bhc a k)" for it a'
note iterator_rule = map_iterator_no_cond_rule_P[
OF ahm_iteratei_aux_impl[OF inv bhc],
of I "new_array [] sz" "ahm_rehash_aux' bhc sz" "I {}"]
from inv have "I {} ?a" unfolding ahm_rehash_aux_def
proof(intro iterator_rule)
from ahm_invar_aux_card_dom_ahm_α_auxD[OF bhc inv]
have "card (dom (ahm_α_aux bhc a)) = n" .
moreover from ahm_invar_aux_new_array[OF ‹1 < sz›]
have "ahm_invar_aux bhc 0 (new_array ([]::('k×'v) list) sz)" .
moreover {
fix k
assume "k ∉ dom (ahm_α_aux bhc a)"
hence "ahm_α_aux bhc a k = None" by auto
hence "ahm_α_aux bhc (new_array [] sz) k = ahm_α_aux bhc a k"
using assms by simp
}
ultimately show "I (dom (ahm_α_aux bhc a)) (new_array [] sz)"
using assms by (simp add: I_def)
next
fix k :: 'k
and v :: 'v
and it a'
assume "k ∈ it" "ahm_α_aux bhc a k = Some v"
and it_sub: "it ⊆ dom (ahm_α_aux bhc a)"
and I: "I it a'"
from I have inv': "ahm_invar_aux bhc (n - card it) a'"
and a'_eq_a: "⋀k. k ∉ it ⟹ ahm_α_aux bhc a' k = ahm_α_aux bhc a k"
and a'_None: "⋀k. k ∈ it ⟹ ahm_α_aux bhc a' k = None"
and [simp]: "sz = array_length a'"
by (auto split: if_split_asm simp: I_def)
from it_sub finite_dom_ahm_α_aux[OF bhc inv]
have "finite it" by(rule finite_subset)
moreover with ‹k ∈ it› have "card it > 0" by (auto simp add: card_gt_0_iff)
moreover from finite_dom_ahm_α_aux[OF bhc inv] it_sub
have "card it ≤ card (dom (ahm_α_aux bhc a))" by (rule card_mono)
moreover have "… = n" using inv
by(simp add: ahm_invar_aux_card_dom_ahm_α_auxD[OF bhc])
ultimately have "n - card (it - {k}) = (n - card it) + 1"
using ‹k ∈ it› by auto
moreover from ‹k ∈ it› have "ahm_α_aux bhc a' k = None" by (rule a'_None)
hence "k ∉ fst ` set (array_get a' (bhc (array_length a') k))"
by (simp add: ahm_α_aux_def2 map_of_eq_None_iff)
ultimately have "ahm_invar_aux bhc (n - card (it - {k}))
(ahm_rehash_aux' bhc sz (k, v) a')"
using ahm_rehash_aux'_preserves_ahm_invar_aux[OF inv' bhc] by simp
moreover have "array_length (ahm_rehash_aux' bhc sz (k, v) a') = sz"
by (simp add: array_length_ahm_rehash_aux')
moreover {
fix k'
assume "k' ∈ it - {k}"
with is_bounded_hashcodeD(3)[OF bhc ‹1 < sz›, of k'] a'_None[of k']
have "ahm_α_aux bhc (ahm_rehash_aux' bhc sz (k, v) a') k' = None"
unfolding ahm_α_aux_def2
by (cases "bhc sz k = bhc sz k'") (simp_all add:
array_get_array_set_other ahm_rehash_aux'_def Let_def)
} moreover {
fix k'
assume "k' ∉ it - {k}"
with is_bounded_hashcodeD(3)[OF bhc ‹1 < sz›, of k]
is_bounded_hashcodeD(3)[OF bhc ‹1 < sz›, of k']
a'_eq_a[of k'] ‹k ∈ it›
have "ahm_α_aux bhc (ahm_rehash_aux' bhc sz (k, v) a') k' =
ahm_α_aux bhc a k'"
unfolding ahm_rehash_aux'_def Let_def
using ‹ahm_α_aux bhc a k = Some v›
unfolding ahm_α_aux_def2
by(cases "bhc sz k = bhc sz k'") (case_tac [!] "k' = k",
simp_all add: array_get_array_set_other)
}
ultimately show "I (it - {k}) (ahm_rehash_aux' bhc sz (k, v) a')"
unfolding I_def by simp
qed simp_all
thus ?thesis1 ?thesis2 unfolding ahm_rehash_aux_def I_def by auto
qed
lemma ahm_rehash_correct:
fixes hm :: "('k, 'v) hashmap"
assumes bhc: "is_bounded_hashcode Id (=) bhc"
and inv: "ahm_invar bhc hm"
and "sz > 1"
shows "ahm_invar bhc (ahm_rehash bhc hm sz)"
"ahm_α bhc (ahm_rehash bhc hm sz) = ahm_α bhc hm"
proof-
obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
from inv have "ahm_invar_aux bhc n a" by simp
from ahm_rehash_aux_correct[OF bhc this ‹sz > 1›]
show "ahm_invar bhc (ahm_rehash bhc hm sz)" and
"ahm_α bhc (ahm_rehash bhc hm sz) = ahm_α bhc hm"
by (simp_all add: ahm_α_def2)
qed
subsection ‹@{term ahm_update}›
lemma param_hm_grow[param]:
"(hm_grow, hm_grow) ∈ ⟨Rk,Rv⟩ahm_map_rel → nat_rel"
unfolding hm_grow_def[abs_def] rec_hashmap_is_case by parametricity
lemma param_ahm_rehash_aux'[param]:
assumes "is_bounded_hashcode Rk eq bhc"
assumes "1 < n"
assumes "(bhc,bhc') ∈ nat_rel → Rk → nat_rel"
assumes "(n,n') ∈ nat_rel" and "n = array_length a"
assumes "(kv,kv') ∈ ⟨Rk,Rv⟩prod_rel"
assumes "(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel"
shows "(ahm_rehash_aux' bhc n kv a, ahm_rehash_aux' bhc' n' kv' a') ∈
⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel"
proof-
from assms have "bhc n (fst kv) < array_length a" by force
thus ?thesis unfolding ahm_rehash_aux'_def[abs_def]
rec_hashmap_is_case Let_def using assms by parametricity
qed
lemma param_new_array[param]:
"(new_array, new_array) ∈ R → nat_rel → ⟨R⟩array_rel"
unfolding new_array_def[abs_def] by parametricity
lemma param_foldli_induct:
assumes l: "(l,l') ∈ ⟨Ra⟩list_rel"
assumes c: "(c,c') ∈ Rb → bool_rel"
assumes σ: "(σ,σ') ∈ Rb"
assumes Pσ: "P σ σ'"
assumes f: "⋀a a' b b'. (a,a')∈Ra ⟹ (b,b')∈Rb ⟹ c b ⟹ c' b' ⟹
P b b' ⟹ (f a b, f' a' b') ∈ Rb ∧
P (f a b) (f' a' b')"
shows "(foldli l c f σ, foldli l' c' f' σ') ∈ Rb"
using c σ Pσ f by (induction arbitrary: σ σ' rule: list_rel_induct[OF l],
auto dest!: fun_relD)
lemma param_foldli_induct_nocond:
assumes l: "(l,l') ∈ ⟨Ra⟩list_rel"
assumes σ: "(σ,σ') ∈ Rb"
assumes Pσ: "P σ σ'"
assumes f: "⋀a a' b b'. (a,a')∈Ra ⟹ (b,b')∈Rb ⟹ P b b' ⟹
(f a b, f' a' b') ∈ Rb ∧ P (f a b) (f' a' b')"
shows "(foldli l (λ_. True) f σ, foldli l' (λ_. True) f' σ') ∈ Rb"
using assms by (blast intro: param_foldli_induct)
lemma param_ahm_rehash_aux[param]:
assumes bhc: "is_bounded_hashcode Rk eq bhc"
assumes bhc_rel: "(bhc,bhc') ∈ nat_rel → Rk → nat_rel"
assumes A: "(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel"
assumes N: "(n,n') ∈ nat_rel" "1 < n"
shows "(ahm_rehash_aux bhc a n, ahm_rehash_aux bhc' a' n') ∈
⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel"
proof-
obtain l l' where [simp]: "a = Array l" "a' = Array l'"
by (cases a, cases a')
from A have L: "(l,l') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩list_rel"
unfolding array_rel_def by simp
hence L': "(concat l, concat l') ∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
by parametricity
let ?P = "λa a'. n = array_length a"
note induct_rule = param_foldli_induct_nocond[OF L', where P="?P"]
show ?thesis unfolding ahm_rehash_aux_def
by (simp, induction rule: induct_rule, insert N bhc bhc_rel,
auto intro: param_new_array[param_fo]
param_ahm_rehash_aux'[param_fo]
simp: array_length_ahm_rehash_aux')
qed
lemma param_ahm_rehash[param]:
assumes bhc: "is_bounded_hashcode Rk eq bhc"
assumes bhc_rel: "(bhc,bhc') ∈ nat_rel → Rk → nat_rel"
assumes M: "(m,m') ∈ ⟨Rk,Rv⟩ahm_map_rel"
assumes N: "(n,n') ∈ nat_rel" "1 < n"
shows "(ahm_rehash bhc m n, ahm_rehash bhc' m' n') ∈
⟨Rk,Rv⟩ahm_map_rel"
proof-
obtain a a' k k' where [simp]: "m = HashMap a k" "m' = HashMap a' k'"
by (cases m, cases m')
hence K: "(k,k') ∈ nat_rel" and
A: "(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel"
using M unfolding ahm_map_rel_def by simp_all
show ?thesis unfolding ahm_rehash_def
by (simp, insert K A assms, parametricity)
qed
lemma param_load_factor[param]:
"(load_factor, load_factor) ∈ nat_rel"
unfolding load_factor_def by simp
lemma param_ahm_filled[param]:
"(ahm_filled, ahm_filled) ∈ ⟨Rk,Rv⟩ahm_map_rel → bool_rel"
unfolding ahm_filled_def[abs_def] rec_hashmap_is_case
by parametricity
lemma param_ahm_update_aux[param]:
assumes bhc: "is_bounded_hashcode Rk eq bhc"
assumes bhc_rel: "(bhc,bhc') ∈ nat_rel → Rk → nat_rel"
assumes inv: "ahm_invar bhc' m'"
assumes K: "(k,k') ∈ Rk"
assumes V: "(v,v') ∈ Rv"
assumes M: "(m,m') ∈ ⟨Rk,Rv⟩ahm_map_rel"
shows "(ahm_update_aux eq bhc m k v,
ahm_update_aux (=) bhc' m' k' v' ) ∈ ⟨Rk,Rv⟩ahm_map_rel"
proof-
from bhc have eq[param]: "(eq, (=))∈Rk → Rk → bool_rel" by (simp add: is_bounded_hashcodeD)
obtain a a' n n' where
[simp]: "m = HashMap a n" and [simp]: "m' = HashMap a' n'"
by (cases m, cases m')
from M have A: "(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel" and
N: "(n,n') ∈ nat_rel"
unfolding ahm_map_rel_def by simp_all
from inv have "1 < array_length a'"
unfolding ahm_invar_def ahm_invar_aux_def by force
hence "1 < array_length a"
by (simp add: array_rel_imp_same_length[OF A])
with bhc have bhc_range: "bhc (array_length a) k < array_length a" by blast
have option_compare: "⋀a a'. (a,a') ∈ ⟨Rv⟩option_rel ⟹
(a = None,a' = None) ∈ bool_rel" by force
have "(array_get a (bhc (array_length a) k),
array_get a' (bhc' (array_length a') k')) ∈
⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
using A K bhc_rel bhc_range by parametricity
note cmp = option_compare[OF param_list_map_lookup[param_fo, OF eq K this]]
show ?thesis apply simp
unfolding ahm_update_aux_def Let_def rec_hashmap_is_case
using assms A N bhc_range cmp by parametricity
qed
lemma param_ahm_update[param]:
assumes bhc: "is_bounded_hashcode Rk eq bhc"
assumes bhc_rel: "(bhc,bhc') ∈ nat_rel → Rk → nat_rel"
assumes inv: "ahm_invar bhc' m'"
assumes K: "(k,k') ∈ Rk"
assumes V: "(v,v') ∈ Rv"
assumes M: "(m,m') ∈ ⟨Rk,Rv⟩ahm_map_rel"
shows "(ahm_update eq bhc k v m, ahm_update (=) bhc' k' v' m') ∈
⟨Rk,Rv⟩ahm_map_rel"
proof-
have "1 < hm_grow (ahm_update_aux eq bhc m k v)" by simp
with assms show ?thesis unfolding ahm_update_def[abs_def] Let_def
by parametricity
qed
lemma length_list_map_update:
"length (list_map_update (=) k v xs) =
(if list_map_lookup (=) k xs = None then Suc (length xs) else length xs)"
(is "?l_new = _")
proof (cases "list_map_lookup (=) k xs", simp_all)
case None
hence "k ∉ dom (map_of xs)" by (force simp: list_map_lookup_is_map_of)
hence "⋀a. list_map_update_aux (=) k v xs a = (k,v) # rev xs @ a"
by (induction xs, auto)
thus "?l_new = Suc (length xs)" unfolding list_map_update_def by simp
next
case (Some v')
hence "(k,v') ∈ set xs" unfolding list_map_lookup_is_map_of
by (rule map_of_SomeD)
hence "⋀a. length (list_map_update_aux (=) k v xs a) =
length xs + length a" by (induction xs, auto)
thus "?l_new = length xs" unfolding list_map_update_def by simp
qed
lemma length_list_map_delete:
"length (list_map_delete (=) k xs) =
(if list_map_lookup (=) k xs = None then length xs else length xs - 1)"
(is "?l_new = _")
proof (cases "list_map_lookup (=) k xs", simp_all)
case None
hence "k ∉ dom (map_of xs)" by (force simp: list_map_lookup_is_map_of)
hence "⋀a. list_map_delete_aux (=) k xs a = rev xs @ a"
by (induction xs, auto)
thus "?l_new = length xs" unfolding list_map_delete_def by simp
next
case (Some v')
hence "(k,v') ∈ set xs" unfolding list_map_lookup_is_map_of
by (rule map_of_SomeD)
hence "⋀a. k ∉ fst`set a ⟹ length (list_map_delete_aux (=) k xs a) =
length xs + length a - 1" by (induction xs, auto)
thus "?l_new = length xs - Suc 0" unfolding list_map_delete_def by simp
qed
lemma ahm_update_impl:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
shows "(ahm_update (=) bhc, op_map_update) ∈ (Id::('k×'k) set) →
(Id::('v×'v) set) → ahm_map_rel' bhc → ahm_map_rel' bhc"
proof (intro fun_relI, clarsimp)
fix k::'k and v::'v and hm::"('k,'v) hashmap" and m::"'k⇀'v"
assume "(hm,m) ∈ ahm_map_rel' bhc"
hence α: "m = ahm_α bhc hm" and inv: "ahm_invar bhc hm"
unfolding ahm_map_rel'_def br_def by simp_all
obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
have K: "(k,k) ∈ Id" and V: "(v,v) ∈ Id" by simp_all
from inv have [simp]: "1 < array_length a"
unfolding ahm_invar_def ahm_invar_aux_def by simp
hence bhc_range[simp]: "⋀k. bhc (array_length a) k < array_length a"
using bhc by blast
let ?l = "array_length a"
let ?h = "bhc (array_length a) k"
let ?a' = "array_set a ?h (list_map_update (=) k v (array_get a ?h))"
let ?n' = "if list_map_lookup (=) k (array_get a ?h) = None
then n + 1 else n"
let ?list = "array_get a (bhc ?l k)"
let ?list' = "map_of ?list"
have L: "(?list, ?list') ∈ br map_of list_map_invar"
using inv unfolding ahm_invar_def ahm_invar_aux_def br_def by simp
hence list: "list_map_invar ?list" by (simp_all add: br_def)
let ?list_new = "list_map_update (=) k v ?list"
let ?list_new' = "op_map_update k v (map_of (?list))"
from list_map_autoref_update2[param_fo, OF K V L]
have list_updated: "map_of ?list_new = ?list_new'"
"list_map_invar ?list_new" unfolding br_def by simp_all
have "ahm_invar bhc (HashMap ?a' ?n')" unfolding ahm_invar.simps
proof(rule ahm_invar_auxI)
fix h
assume "h < array_length ?a'"
hence h_in_range: "h < array_length a" by simp
with inv have bucket_ok: "bucket_ok bhc ?l h (array_get a h)"
by(auto elim: ahm_invar_auxD)
thus "bucket_ok bhc (array_length ?a') h (array_get ?a' h)"
proof (cases "h = bhc (array_length a) k")
case False
with bucket_ok show ?thesis
by (intro bucket_okI, force simp add:
array_get_array_set_other dest: bucket_okD)
next
case True
show ?thesis
proof (insert True, simp, intro bucket_okI, goal_cases)
case prems: (1 k')
show ?case
proof (cases "k = k'")
case False
from prems have "k' ∈ dom ?list_new'"
by (simp only: dom_map_of_conv_image_fst
list_updated(1)[symmetric])
hence "k' ∈ fst`set ?list" using False
by (simp add: dom_map_of_conv_image_fst)
from imageE[OF this] obtain x where
"fst x = k'" and "x ∈ set ?list" by force
then obtain v' where "(k',v') ∈ set ?list"
by (cases x, simp)
with bucket_okD[OF bucket_ok] and
‹h = bhc (array_length a) k›
show ?thesis by simp
qed simp
qed
qed
from ‹h < array_length a› inv have "list_map_invar (array_get a h)"
by(auto dest: ahm_invar_auxD)
with ‹h < array_length a›
show "list_map_invar (array_get ?a' h)"
by (cases "h = ?h", simp_all add:
list_updated array_get_array_set_other)
next
obtain xs where a [simp]: "a = Array xs" by(cases a)
let ?f = "λn kvs. n + length kvs"
{ fix n :: nat and xs :: "('k × 'v) list list"
have "foldl ?f n xs = n + foldl ?f 0 xs"
by(induct xs arbitrary: rule: rev_induct) simp_all }
note fold = this
from inv have [simp]: "bhc (length xs) k < length xs"
using bhc_range by simp
have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs"
by(simp add: Cons_nth_drop_Suc)
from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
by (force dest: ahm_invar_auxD)
hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
apply (simp add: array_foldl_foldl)
apply (subst xs)
apply simp
apply (metis fold)
done
thus "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
apply(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update map_of_eq_None_iff)
apply(subst (1 2 3 4 5 6 7 8) fold)
apply(simp add: length_list_map_update)
done
next
from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
thus "1 < array_length ?a'" by simp
next
qed
moreover have "ahm_α bhc (ahm_update_aux (=) bhc hm k v) =
ahm_α bhc hm(k ↦ v)"
proof
fix k'
show "ahm_α bhc (ahm_update_aux (=) bhc hm k v) k' = (ahm_α bhc hm(k ↦ v)) k'"
proof (cases "bhc ?l k = bhc ?l k'")
case False
thus ?thesis by (force simp add: Let_def
ahm_α_def array_get_array_set_other)
next
case True
hence "bhc ?l k' = bhc ?l k" by simp
thus ?thesis by (auto simp add: Let_def ahm_α_def
list_map_lookup_is_map_of list_updated)
qed
qed
ultimately have ref: "(ahm_update_aux (=) bhc hm k v,
m(k ↦ v)) ∈ ahm_map_rel' bhc" (is "(?hm',_)∈_")
unfolding ahm_map_rel'_def br_def using α by (auto simp: Let_def)
show "(ahm_update (=) bhc k v hm, m(k ↦ v))
∈ ahm_map_rel' bhc"
proof (cases "ahm_filled ?hm'")
case False
with ref show ?thesis unfolding ahm_update_def
by (simp del: ahm_update_aux.simps)
next
case True
from ref have "(ahm_rehash bhc ?hm' (hm_grow ?hm'), m(k ↦ v)) ∈
ahm_map_rel' bhc" unfolding ahm_map_rel'_def br_def
by (simp del: ahm_update_aux.simps
add: ahm_rehash_correct[OF bhc])
thus ?thesis unfolding ahm_update_def using True
by (simp del: ahm_update_aux.simps add: Let_def)
qed
qed
lemma autoref_ahm_update[autoref_rules]:
assumes bhc[unfolded autoref_tag_defs]:
"SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
shows "(ahm_update eq bhc, op_map_update) ∈
Rk → Rv → ⟨Rk,Rv⟩ahm_rel bhc → ⟨Rk,Rv⟩ahm_rel bhc"
proof (intro fun_relI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix k k' v v' a m'
assume K: "(k,k') ∈ Rk" and V: "(v,v') ∈ Rv"
assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
with bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" by blast
from abstract_bhc_correct[OF bhc]
have bhc_rel: "(bhc,?bhc') ∈ nat_rel → Rk → nat_rel" .
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
hence inv: "ahm_invar ?bhc' a'"
unfolding ahm_map_rel'_def br_def by simp
from relcompI[OF param_ahm_update[OF bhc bhc_rel inv K V M1]
ahm_update_impl[param_fo, OF bhc' _ _ M2]]
show "(ahm_update eq bhc k v a, op_map_update k' v' m') ∈
⟨Rk,Rv⟩ahm_rel bhc" unfolding ahm_rel_def by simp
qed
subsection ‹@{term "ahm_delete"}›
lemma param_ahm_delete[param]:
assumes isbhc: "is_bounded_hashcode Rk eq bhc"
assumes bhc: "(bhc,bhc') ∈ nat_rel → Rk → nat_rel"
assumes inv: "ahm_invar bhc' m'"
assumes K: "(k,k') ∈ Rk"
assumes M: "(m,m') ∈ ⟨Rk,Rv⟩ahm_map_rel"
shows
"(ahm_delete eq bhc k m, ahm_delete (=) bhc' k' m') ∈
⟨Rk,Rv⟩ahm_map_rel"
proof-
from isbhc have eq: "(eq,(=))∈Rk→Rk→bool_rel" by (simp add: is_bounded_hashcodeD)
obtain a a' n n' where
[simp]: "m = HashMap a n" and [simp]: "m' = HashMap a' n'"
by (cases m, cases m')
from M have A: "(a,a') ∈ ⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩array_rel" and
N: "(n,n') ∈ nat_rel"
unfolding ahm_map_rel_def by simp_all
from inv have "1 < array_length a'"
unfolding ahm_invar_def ahm_invar_aux_def by force
hence "1 < array_length a"
by (simp add: array_rel_imp_same_length[OF A])
with isbhc have bhc_range: "bhc (array_length a) k < array_length a" by blast
have option_compare: "⋀a a'. (a,a') ∈ ⟨Rv⟩option_rel ⟹
(a = None,a' = None) ∈ bool_rel" by force
have "(array_get a (bhc (array_length a) k),
array_get a' (bhc' (array_length a') k')) ∈
⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
using A K bhc bhc_range by parametricity
note cmp = option_compare[OF param_list_map_lookup[param_fo, OF eq K this]]
show ?thesis unfolding ‹m = HashMap a n› ‹m' = HashMap a' n'›
by (simp only: ahm_delete.simps Let_def,
insert eq isbhc bhc K A N bhc_range cmp, parametricity)
qed
lemma ahm_delete_impl:
assumes bhc: "is_bounded_hashcode Id (=) bhc"
shows "(ahm_delete (=) bhc, op_map_delete) ∈ (Id::('k×'k) set) →
ahm_map_rel' bhc → ahm_map_rel' bhc"
proof (intro fun_relI, clarsimp)
fix k::'k and hm::"('k,'v) hashmap" and m::"'k⇀'v"
assume "(hm,m) ∈ ahm_map_rel' bhc"
hence α: "m = ahm_α bhc hm" and inv: "ahm_invar bhc hm"
unfolding ahm_map_rel'_def br_def by simp_all
obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
have K: "(k,k) ∈ Id" by simp
from inv have [simp]: "1 < array_length a"
unfolding ahm_invar_def ahm_invar_aux_def by simp
hence bhc_range[simp]: "⋀k. bhc (array_length a) k < array_length a"
using bhc by blast
let ?l = "array_length a"
let ?h = "bhc ?l k"
let ?a' = "array_set a ?h (list_map_delete (=) k (array_get a ?h))"
let ?n' = "if list_map_lookup (=) k (array_get a ?h) = None then n else n - 1"
let ?list = "array_get a ?h" let ?list' = "map_of ?list"
let ?list_new = "list_map_delete (=) k ?list"
let ?list_new' = "?list' |` (-{k})"
from inv have "(?list, ?list') ∈ br map_of list_map_invar"
unfolding br_def ahm_invar_def ahm_invar_aux_def by simp
from list_map_autoref_delete2[param_fo, OF K this]
have list_updated: "map_of ?list_new = ?list_new'"
"list_map_invar ?list_new" by (simp_all add: br_def)
have [simp]: "array_length ?a' = ?l" by simp
have "ahm_invar_aux bhc ?n' ?a'"
proof(rule ahm_invar_auxI)
fix h
assume "h < array_length ?a'"
hence h_in_range[simp]: "h < array_length a" by simp
with inv have inv': "bucket_ok bhc ?l h (array_get a h)" "1 < ?l"
"list_map_invar (array_get a h)" by (auto elim: ahm_invar_auxE)
show "bucket_ok bhc (array_length ?a') h (array_get ?a' h)"
proof (cases "h = bhc ?l k")
case False thus ?thesis using inv'
by (simp add: array_get_array_set_other)
next
case True thus ?thesis
proof (simp, intro bucket_okI, goal_cases)
case prems: (1 k')
show ?case
proof (cases "k = k'")
case False
from prems have "k' ∈ dom ?list_new'"
by (simp only: dom_map_of_conv_image_fst
list_updated(1)[symmetric])
hence "k' ∈ fst`set ?list" using False
by (simp add: dom_map_of_conv_image_fst)
from imageE[OF this] obtain x where
"fst x = k'" and "x ∈ set ?list" by force
then obtain v' where "(k',v') ∈ set ?list"
by (cases x, simp)
with bucket_okD[OF inv'(1)] and
‹h = bhc (array_length a) k›
show ?thesis by blast
qed simp
qed
qed
from inv'(3) ‹h < array_length a›
show "list_map_invar (array_get ?a' h)"
by (cases "h = ?h", simp_all add:
list_updated array_get_array_set_other)
next
obtain xs where a [simp]: "a = Array xs" by(cases a)
let ?f = "λn kvs. n + length (kvs::('k×'v) list)"
{ fix n :: nat and xs :: "('k×'v) list list"
have "foldl ?f n xs = n + foldl ?f 0 xs"
by(induct xs arbitrary: rule: rev_induct) simp_all }
note fold = this
from bhc_range have [simp]: "bhc (length xs) k < length xs" by simp
moreover
have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
by(auto elim: ahm_invar_auxE)
hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
moreover have "⋀v a b. list_map_lookup (=) k (xs ! ?h) = Some v
⟹ a + (length (xs ! ?h) - 1) + b = a + length (xs ! ?h) + b - 1"
by (cases "xs ! ?h", simp_all)
ultimately show "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
apply(simp add: array_foldl_foldl foldl_list_update map_of_eq_None_iff)
apply(subst (1 2 3 4 5 6 7 8) fold)
apply (intro conjI impI)
apply(auto simp add: length_list_map_delete)
done
next
from inv show "1 < array_length ?a'" by(auto elim: ahm_invar_auxE)
qed
hence "ahm_invar bhc (HashMap ?a' ?n')" by simp
moreover have "ahm_α_aux bhc ?a' = ahm_α_aux bhc a |` (- {k})"
proof
fix k' :: 'k
show "ahm_α_aux bhc ?a' k' = (ahm_α_aux bhc a |` (- {k})) k'"
proof (cases "bhc ?l k' = ?h")
case False
hence "k ≠ k'" by force
thus ?thesis using False unfolding ahm_α_aux_def
by (simp add: array_get_array_set_other
list_map_lookup_is_map_of)
next
case True
thus ?thesis unfolding ahm_α_aux_def
by (simp add: list_map_lookup_is_map_of
list_updated(1) restrict_map_def)
qed
qed
hence "ahm_α bhc (HashMap ?a' ?n') = op_map_delete k m"
unfolding op_map_delete_def by (simp add: ahm_α_def2 α)
ultimately have "(HashMap ?a' ?n', op_map_delete k m) ∈ ahm_map_rel' bhc"
unfolding ahm_map_rel'_def br_def by simp
thus "(ahm_delete (=) bhc k hm, m |` (-{k})) ∈ ahm_map_rel' bhc"
by (simp only: ‹hm = HashMap a n› ahm_delete.simps Let_def
op_map_delete_def, force)
qed
lemma autoref_ahm_delete[autoref_rules]:
assumes bhc[unfolded autoref_tag_defs]:
"SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
shows "(ahm_delete eq bhc, op_map_delete) ∈
Rk → ⟨Rk,Rv⟩ahm_rel bhc → ⟨Rk,Rv⟩ahm_rel bhc"
proof (intro fun_relI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix k k' a m'
assume K: "(k,k') ∈ Rk"
assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
with bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" by blast
from abstract_bhc_correct[OF bhc]
have bhc_rel: "(bhc,?bhc') ∈ nat_rel → Rk → nat_rel" .
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
hence inv: "ahm_invar ?bhc' a'"
unfolding ahm_map_rel'_def br_def by simp
from relcompI[OF param_ahm_delete[OF bhc bhc_rel inv K M1]
ahm_delete_impl[param_fo, OF bhc' _ M2]]
show "(ahm_delete eq bhc k a, op_map_delete k' m') ∈
⟨Rk,Rv⟩ahm_rel bhc" unfolding ahm_rel_def by simp
qed
subsection ‹Various simple operations›
lemma param_ahm_isEmpty[param]:
"(ahm_isEmpty, ahm_isEmpty) ∈ ⟨Rk,Rv⟩ahm_map_rel → bool_rel"
unfolding ahm_isEmpty_def[abs_def] rec_hashmap_is_case
by parametricity
lemma param_ahm_isSng[param]:
"(ahm_isSng, ahm_isSng) ∈ ⟨Rk,Rv⟩ahm_map_rel → bool_rel"
unfolding ahm_isSng_def[abs_def] rec_hashmap_is_case
by parametricity
lemma param_ahm_size[param]:
"(ahm_size, ahm_size) ∈ ⟨Rk,Rv⟩ahm_map_rel → nat_rel"
unfolding ahm_size_def[abs_def] rec_hashmap_is_case
by parametricity
lemma ahm_isEmpty_impl:
assumes "is_bounded_hashcode Id (=) bhc"
shows "(ahm_isEmpty, op_map_isEmpty) ∈ ahm_map_rel' bhc → bool_rel"
proof (intro fun_relI)
fix hm m assume rel: "(hm,m) ∈ ahm_map_rel' bhc"
obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
from rel have α: "m = ahm_α_aux bhc a" and inv: "ahm_invar_aux bhc n a"
unfolding ahm_map_rel'_def br_def by (simp_all add: ahm_α_def2)
from ahm_invar_aux_card_dom_ahm_α_auxD[OF assms inv,symmetric] and
finite_dom_ahm_α_aux[OF assms inv]
show "(ahm_isEmpty hm, op_map_isEmpty m) ∈ bool_rel"
unfolding ahm_isEmpty_def op_map_isEmpty_def
by (simp add: α card_eq_0_iff)
qed
lemma ahm_isSng_impl:
assumes "is_bounded_hashcode Id (=) bhc"
shows "(ahm_isSng, op_map_isSng) ∈ ahm_map_rel' bhc → bool_rel"
proof (intro fun_relI)
fix hm m assume rel: "(hm,m) ∈ ahm_map_rel' bhc"
obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
from rel have α: "m = ahm_α_aux bhc a" and inv: "ahm_invar_aux bhc n a"
unfolding ahm_map_rel'_def br_def by (simp_all add: ahm_α_def2)
note n_props[simp] = ahm_invar_aux_card_dom_ahm_α_auxD[OF assms inv,symmetric]
note finite_dom[simp] = finite_dom_ahm_α_aux[OF assms inv]
show "(ahm_isSng hm, op_map_isSng m) ∈ bool_rel"
by (force simp add: α[symmetric] dom_eq_singleton_conv
dest!: card_eq_SucD)
qed
lemma ahm_size_impl:
assumes "is_bounded_hashcode Id (=) bhc"
shows "(ahm_size, op_map_size) ∈ ahm_map_rel' bhc → nat_rel"
proof (intro fun_relI)
fix hm m assume rel: "(hm,m) ∈ ahm_map_rel' bhc"
obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
from rel have α: "m = ahm_α_aux bhc a" and inv: "ahm_invar_aux bhc n a"
unfolding ahm_map_rel'_def br_def by (simp_all add: ahm_α_def2)
from ahm_invar_aux_card_dom_ahm_α_auxD[OF assms inv,symmetric]
show "(ahm_size hm, op_map_size m) ∈ nat_rel"
unfolding ahm_isEmpty_def op_map_isEmpty_def
by (simp add: α card_eq_0_iff)
qed
lemma autoref_ahm_isEmpty[autoref_rules]:
assumes bhc[unfolded autoref_tag_defs]:
"SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
shows "(ahm_isEmpty, op_map_isEmpty) ∈ ⟨Rk,Rv⟩ahm_rel bhc → bool_rel"
proof (intro fun_relI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix k k' a m'
assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'"
by blast
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
from relcompI[OF param_ahm_isEmpty[param_fo, OF M1]
ahm_isEmpty_impl[param_fo, OF bhc' M2]]
show "(ahm_isEmpty a, op_map_isEmpty m') ∈ bool_rel" by simp
qed
lemma autoref_ahm_isSng[autoref_rules]:
assumes bhc[unfolded autoref_tag_defs]:
"SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
shows "(ahm_isSng, op_map_isSng) ∈ ⟨Rk,Rv⟩ahm_rel bhc → bool_rel"
proof (intro fun_relI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix k k' a m'
assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'"
by blast
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
from relcompI[OF param_ahm_isSng[param_fo, OF M1]
ahm_isSng_impl[param_fo, OF bhc' M2]]
show "(ahm_isSng a, op_map_isSng m') ∈ bool_rel" by simp
qed
lemma autoref_ahm_size[autoref_rules]:
assumes bhc[unfolded autoref_tag_defs]:
"SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
shows "(ahm_size, op_map_size) ∈ ⟨Rk,Rv⟩ahm_rel bhc → nat_rel"
proof (intro fun_relI)
let ?bhc' = "abstract_bounded_hashcode Rk bhc"
fix k k' a m'
assume M: "(a,m') ∈ ⟨Rk,Rv⟩ahm_rel bhc"
from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'"
by blast
from M obtain a' where M1: "(a,a') ∈ ⟨Rk,Rv⟩ahm_map_rel" and
M2: "(a',m') ∈ ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
from relcompI[OF param_ahm_size[param_fo, OF M1]
ahm_size_impl[param_fo, OF bhc' M2]]
show "(ahm_size a, op_map_size m') ∈ nat_rel" by simp
qed
lemma ahm_map_rel_sv[relator_props]:
assumes SK: "single_valued Rk"
assumes SV: "single_valued Rv"
shows "single_valued (⟨Rk, Rv⟩ahm_map_rel)"
proof -
from SK SV have 1: "single_valued (⟨⟨⟨Rk, Rv⟩prod_rel⟩list_rel⟩array_rel)"
by (tagged_solver)
thus ?thesis
unfolding ahm_map_rel_def
by (auto intro: single_valuedI dest: single_valuedD[OF 1])
qed
lemma ahm_rel_sv[relator_props]:
"⟦single_valued Rk; single_valued Rv⟧
⟹ single_valued (⟨Rk,Rv⟩ahm_rel bhc)"
unfolding ahm_rel_def ahm_map_rel'_def
by (tagged_solver (keep))
lemma rbt_map_rel_finite[relator_props]:
assumes A[simplified]: "GEN_ALGO_tag (is_bounded_hashcode Rk eq bhc)"
shows "finite_map_rel (⟨Rk,Rv⟩ahm_rel bhc)"
unfolding ahm_rel_def finite_map_rel_def ahm_map_rel'_def br_def
apply auto
apply (case_tac y)
apply (auto simp: ahm_α_def2)
thm finite_dom_ahm_α_aux
apply (rule finite_dom_ahm_α_aux)
apply (rule abstract_bhc_is_bhc)
apply (rule A)
apply assumption
done
subsection ‹Proper iterator proofs›
lemma pi_ahm[icf_proper_iteratorI]:
"proper_it (ahm_iteratei m) (ahm_iteratei m)"
proof-
obtain a n where [simp]: "m = HashMap a n" by (cases m)
then obtain l where [simp]: "a = Array l" by (cases a)
thus ?thesis
unfolding proper_it_def list_map_iteratei_def
by (simp add: ahm_iteratei_aux_def, blast)
qed
lemma pi'_ahm[icf_proper_iteratorI]:
"proper_it' ahm_iteratei ahm_iteratei"
by (rule proper_it'I, rule pi_ahm)
lemmas autoref_ahm_rules =
autoref_ahm_empty
autoref_ahm_lookup
autoref_ahm_update
autoref_ahm_delete
autoref_ahm_isEmpty
autoref_ahm_isSng
autoref_ahm_size
lemmas autoref_ahm_rules_hashable[autoref_rules_raw]
= autoref_ahm_rules[where Rk="Rk"] for Rk :: "(_×_::hashable) set"
end
Theory Impl_RBT_Map
section ‹\isaheader{Red-Black Tree based Maps}›
theory Impl_RBT_Map
imports
"HOL-Library.RBT_Impl"
"../../Lib/RBT_add"
Automatic_Refinement.Automatic_Refinement
"../../Iterator/Iterator"
"../Intf/Intf_Comp"
"../Intf/Intf_Map"
begin
subsection ‹Standard Setup›
inductive_set color_rel where
"(color.R,color.R) ∈ color_rel"
| "(color.B,color.B) ∈ color_rel"
inductive_cases color_rel_elims:
"(x,color.R) ∈ color_rel"
"(x,color.B) ∈ color_rel"
"(color.R,y) ∈ color_rel"
"(color.B,y) ∈ color_rel"
thm color_rel_elims
lemma param_color[param]:
"(color.R,color.R)∈color_rel"
"(color.B,color.B)∈color_rel"
"(case_color,case_color)∈R → R → color_rel → R"
by (auto
intro: color_rel.intros
elim: color_rel.cases
split: color.split)
inductive_set rbt_rel_aux for Ra Rb where
"(rbt.Empty,rbt.Empty)∈rbt_rel_aux Ra Rb"
| "⟦ (c,c')∈color_rel;
(l,l')∈rbt_rel_aux Ra Rb; (a,a')∈Ra; (b,b')∈Rb;
(r,r')∈rbt_rel_aux Ra Rb ⟧
⟹ (rbt.Branch c l a b r, rbt.Branch c' l' a' b' r')∈rbt_rel_aux Ra Rb"
inductive_cases rbt_rel_aux_elims:
"(x,rbt.Empty)∈rbt_rel_aux Ra Rb"
"(rbt.Empty,x')∈rbt_rel_aux Ra Rb"
"(rbt.Branch c l a b r,x')∈rbt_rel_aux Ra Rb"
"(x,rbt.Branch c' l' a' b' r')∈rbt_rel_aux Ra Rb"
definition "rbt_rel ≡ rbt_rel_aux"
lemma rbt_rel_aux_fold: "rbt_rel_aux Ra Rb ≡ ⟨Ra,Rb⟩rbt_rel"
by (simp add: rbt_rel_def relAPP_def)
lemmas rbt_rel_intros = rbt_rel_aux.intros[unfolded rbt_rel_aux_fold]
lemmas rbt_rel_cases = rbt_rel_aux.cases[unfolded rbt_rel_aux_fold]
lemmas rbt_rel_induct[induct set]
= rbt_rel_aux.induct[unfolded rbt_rel_aux_fold]
lemmas rbt_rel_elims = rbt_rel_aux_elims[unfolded rbt_rel_aux_fold]
lemma param_rbt1[param]:
"(rbt.Empty,rbt.Empty) ∈ ⟨Ra,Rb⟩rbt_rel"
"(rbt.Branch,rbt.Branch) ∈
color_rel → ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
by (auto intro: rbt_rel_intros)
lemma param_case_rbt[param]:
"(case_rbt,case_rbt) ∈
Ra → (color_rel → ⟨Rb,Rc⟩rbt_rel → Rb → Rc → ⟨Rb,Rc⟩rbt_rel → Ra)
→ ⟨Rb,Rc⟩rbt_rel → Ra"
apply clarsimp
apply (erule rbt_rel_cases)
apply simp
apply simp
apply parametricity
done
lemma param_rec_rbt[param]: "(rec_rbt, rec_rbt) ∈
Ra → (color_rel → ⟨Rb,Rc⟩rbt_rel → Rb → Rc → ⟨Rb,Rc⟩rbt_rel
→ Ra → Ra → Ra) → ⟨Rb,Rc⟩rbt_rel → Ra"
proof (intro fun_relI, goal_cases)
case (1 s s' f f' t t') from this(3,1,2) show ?case
apply (induct arbitrary: s s')
apply simp
apply simp
apply parametricity
done
qed
lemma param_paint[param]:
"(paint,paint)∈color_rel → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
unfolding paint_def
by parametricity
lemma param_balance[param]:
shows "(balance,balance) ∈
⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 t1 t1' a a' b b' t2 t2')
thus ?case
apply (induct t1' a' b' t2' arbitrary: t1 a b t2 rule: balance.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: balance.simps)
apply (parametricity)+
done
qed
lemma param_rbt_ins[param]:
fixes less
assumes param_less[param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_ins less,ord.rbt_ins less') ∈
(Ra→Rb→Rb→Rb) → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 f f' a a' b b' t t')
thus ?case
apply (induct f' a' b' t' arbitrary: f a b t rule: ord.rbt_ins.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: ord.rbt_ins.simps rbt_ins.simps)
apply parametricity+
done
qed
term rbt_insert
lemma param_rbt_insert[param]:
fixes less
assumes param_less[param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_insert less,ord.rbt_insert less') ∈
Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
unfolding rbt_insert_def ord.rbt_insert_def
unfolding rbt_insert_with_key_def[abs_def]
ord.rbt_insert_with_key_def[abs_def]
by parametricity
lemma param_rbt_lookup[param]:
fixes less
assumes param_less[param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_lookup less,ord.rbt_lookup less') ∈
⟨Ra,Rb⟩rbt_rel → Ra → ⟨Rb⟩option_rel"
unfolding rbt_lookup_def ord.rbt_lookup_def
by parametricity
term balance_left
lemma param_balance_left[param]:
"(balance_left, balance_left) ∈
⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 l l' a a' b b' r r')
thus ?case
apply (induct l a b r arbitrary: l' a' b' r' rule: balance_left.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: balance_left.simps)
apply parametricity+
done
qed
term balance_right
lemma param_balance_right[param]:
"(balance_right, balance_right) ∈
⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 l l' a a' b b' r r')
thus ?case
apply (induct l a b r arbitrary: l' a' b' r' rule: balance_right.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: balance_right.simps)
apply parametricity+
done
qed
lemma param_combine[param]:
"(combine,combine)∈⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 t1 t1' t2 t2')
thus ?case
apply (induct t1 t2 arbitrary: t1' t2' rule: combine.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: combine.simps)
apply parametricity+
done
qed
lemma ih_aux1: "⟦ (a',b)∈R; a'=a ⟧ ⟹ (a,b)∈R" by auto
lemma is_eq: "a=b ⟹ a=b" .
lemma param_rbt_del_aux:
fixes br
fixes less
assumes param_less[param]: "(less,less') ∈ Ra → Ra → Id"
shows
"⟦ (ak1,ak1')∈Ra; (al,al')∈⟨Ra,Rb⟩rbt_rel; (ak,ak')∈Ra;
(av,av')∈Rb; (ar,ar')∈⟨Ra,Rb⟩rbt_rel
⟧ ⟹ (ord.rbt_del_from_left less ak1 al ak av ar,
ord.rbt_del_from_left less' ak1' al' ak' av' ar')
∈ ⟨Ra,Rb⟩rbt_rel"
"⟦ (bk1,bk1')∈Ra; (bl,bl')∈⟨Ra,Rb⟩rbt_rel; (bk,bk')∈Ra;
(bv,bv')∈Rb; (br,br')∈⟨Ra,Rb⟩rbt_rel
⟧ ⟹ (ord.rbt_del_from_right less bk1 bl bk bv br,
ord.rbt_del_from_right less' bk1' bl' bk' bv' br')
∈ ⟨Ra,Rb⟩rbt_rel"
"⟦ (ck,ck')∈Ra; (ct,ct')∈⟨Ra,Rb⟩rbt_rel ⟧
⟹ (ord.rbt_del less ck ct, ord.rbt_del less' ck' ct') ∈ ⟨Ra,Rb⟩rbt_rel"
apply (induct
ak1' al' ak' av' ar' and bk1' bl' bk' bv' br' and ck' ct'
arbitrary: ak1 al ak av ar and bk1 bl bk bv br and ck ct
rule: ord.rbt_del_from_left_rbt_del_from_right_rbt_del.induct)
apply (assumption
| elim rbt_rel_elims color_rel_elims
| simp (no_asm_use) only: rbt_del.simps ord.rbt_del.simps
rbt_del_from_left.simps ord.rbt_del_from_left.simps
rbt_del_from_right.simps ord.rbt_del_from_right.simps
| parametricity
| rule rbt_rel_intros
| hypsubst
| (simp, rule ih_aux1, rprems)
| (rule is_eq, simp)
) +
done
lemma param_rbt_del[param]:
fixes less
assumes param_less: "(less,less') ∈ Ra → Ra → Id"
shows
"(ord.rbt_del_from_left less, ord.rbt_del_from_left less') ∈
Ra → ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
"(ord.rbt_del_from_right less, ord.rbt_del_from_right less') ∈
Ra → ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
"(ord.rbt_del less,ord.rbt_del less') ∈
Ra → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
by (intro fun_relI, blast intro: param_rbt_del_aux[OF param_less])+
lemma param_rbt_delete[param]:
fixes less
assumes param_less[param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_delete less, ord.rbt_delete less')
∈ Ra → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
unfolding rbt_delete_def[abs_def] ord.rbt_delete_def[abs_def]
by parametricity
term ord.rbt_insert_with_key
abbreviation compare_rel :: "(RBT_Impl.compare × _) set"
where "compare_rel ≡ Id"
lemma param_compare[param]:
"(RBT_Impl.LT,RBT_Impl.LT)∈compare_rel"
"(RBT_Impl.GT,RBT_Impl.GT)∈compare_rel"
"(RBT_Impl.EQ,RBT_Impl.EQ)∈compare_rel"
"(RBT_Impl.case_compare,RBT_Impl.case_compare)∈R→R→R→compare_rel→R"
by (auto split: RBT_Impl.compare.split)
lemma param_rbtreeify_aux[param]:
"⟦n≤length kvs; (n,n')∈nat_rel; (kvs,kvs')∈⟨⟨Ra,Rb⟩prod_rel⟩list_rel⟧
⟹ (rbtreeify_f n kvs,rbtreeify_f n' kvs')
∈ ⟨⟨Ra,Rb⟩rbt_rel, ⟨⟨Ra,Rb⟩prod_rel⟩list_rel⟩prod_rel"
"⟦n≤Suc (length kvs); (n,n')∈nat_rel; (kvs,kvs')∈⟨⟨Ra,Rb⟩prod_rel⟩list_rel⟧
⟹ (rbtreeify_g n kvs,rbtreeify_g n' kvs')
∈ ⟨⟨Ra,Rb⟩rbt_rel, ⟨⟨Ra,Rb⟩prod_rel⟩list_rel⟩prod_rel"
apply (induct n kvs and n kvs
arbitrary: n' kvs' and n' kvs'
rule: rbtreeify_induct)
apply (simp only: pair_in_Id_conv)
apply (simp (no_asm_use) only: rbtreeify_f_simps rbtreeify_g_simps)
apply parametricity
apply (elim list_relE prod_relE)
apply (simp only: pair_in_Id_conv)
apply hypsubst
apply (simp (no_asm_use) only: rbtreeify_f_simps rbtreeify_g_simps)
apply parametricity
apply clarsimp
apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a)
∈ ⟨⟨Ra, Rb⟩rbt_rel, ⟨⟨Ra, Rb⟩prod_rel⟩list_rel⟩prod_rel")
apply (clarsimp elim!: list_relE prod_relE)
apply parametricity
apply (rule refl)
apply rprems
apply (rule refl)
apply assumption
apply clarsimp
apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a)
∈ ⟨⟨Ra, Rb⟩rbt_rel, ⟨⟨Ra, Rb⟩prod_rel⟩list_rel⟩prod_rel")
apply (clarsimp elim!: list_relE prod_relE)
apply parametricity
apply (rule refl)
apply rprems
apply (rule refl)
apply assumption
apply simp
apply parametricity
apply clarsimp
apply parametricity
apply clarsimp
apply (subgoal_tac "(rbtreeify_g n kvs, rbtreeify_g n kvs'a)
∈ ⟨⟨Ra, Rb⟩rbt_rel, ⟨⟨Ra, Rb⟩prod_rel⟩list_rel⟩prod_rel")
apply (clarsimp elim!: list_relE prod_relE)
apply parametricity
apply (rule refl)
apply parametricity
apply (rule refl)
apply clarsimp
apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a)
∈ ⟨⟨Ra, Rb⟩rbt_rel, ⟨⟨Ra, Rb⟩prod_rel⟩list_rel⟩prod_rel")
apply (clarsimp elim!: list_relE prod_relE)
apply parametricity
apply (rule refl)
apply parametricity
apply (rule refl)
done
lemma param_rbtreeify[param]:
"(rbtreeify, rbtreeify) ∈ ⟨⟨Ra,Rb⟩prod_rel⟩list_rel → ⟨Ra,Rb⟩rbt_rel"
unfolding rbtreeify_def[abs_def]
apply parametricity
by simp
lemma param_sunion_with[param]:
fixes less
shows "⟦ (less,less') ∈ Ra → Ra → Id;
(f,f')∈(Ra→Rb→Rb→Rb); (a,a')∈⟨⟨Ra,Rb⟩prod_rel⟩list_rel;
(b,b')∈⟨⟨Ra,Rb⟩prod_rel⟩list_rel ⟧
⟹ (ord.sunion_with less f a b, ord.sunion_with less' f' a' b') ∈
⟨⟨Ra,Rb⟩prod_rel⟩list_rel"
apply (induct f' a' b' arbitrary: f a b
rule: ord.sunion_with.induct[of less'])
apply (elim_all list_relE prod_relE)
apply (simp_all only: ord.sunion_with.simps)
apply parametricity
apply simp_all
done
lemma skip_red_alt:
"RBT_Impl.skip_red t = (case t of
(Branch color.R l k v r) ⇒ l
| _ ⇒ t)"
by (auto split: rbt.split color.split)
function compare_height ::
"('a, 'b) RBT_Impl.rbt ⇒ ('a, 'b) RBT_Impl.rbt ⇒ ('a, 'b) RBT_Impl.rbt ⇒ ('a, 'b) RBT_Impl.rbt ⇒ RBT_Impl.compare"
where
"compare_height sx s t tx =
(case (RBT_Impl.skip_red sx, RBT_Impl.skip_red s, RBT_Impl.skip_red t, RBT_Impl.skip_red tx) of
(Branch _ sx' _ _ _, Branch _ s' _ _ _, Branch _ t' _ _ _, Branch _ tx' _ _ _) ⇒
compare_height (RBT_Impl.skip_black sx') s' t' (RBT_Impl.skip_black tx')
| (_, rbt.Empty, _, Branch _ _ _ _ _) ⇒ RBT_Impl.LT
| (Branch _ _ _ _ _, _, rbt.Empty, _) ⇒ RBT_Impl.GT
| (Branch _ sx' _ _ _, Branch _ s' _ _ _, Branch _ t' _ _ _, rbt.Empty) ⇒
compare_height (RBT_Impl.skip_black sx') s' t' rbt.Empty
| (rbt.Empty, Branch _ s' _ _ _, Branch _ t' _ _ _, Branch _ tx' _ _ _) ⇒
compare_height rbt.Empty s' t' (RBT_Impl.skip_black tx')
| _ ⇒ RBT_Impl.EQ)"
by pat_completeness auto
lemma skip_red_size: "size (RBT_Impl.skip_red b) ≤ size b"
by (auto simp add: skip_red_alt split: rbt.split color.split)
lemma skip_black_size: "size (RBT_Impl.skip_black b) ≤ size b"
unfolding RBT_Impl.skip_black_def
apply (auto
simp add: Let_def
split: rbt.split color.split
)
using skip_red_size[of b]
apply auto
done
termination
proof -
{
fix s t x
assume A: "s = RBT_Impl.skip_red t"
and B: "x < size s"
note B
also note A
also note skip_red_size
finally have "x < size t" .
} note AUX=this
show "All compare_height_dom"
apply (relation
"measure (λ(a, b, c, d). size a + size b + size c + size d)")
apply rule
apply (clarsimp simp: Let_def split: rbt.splits color.splits)
apply (intro add_less_mono trans_less_add2
order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []
apply (clarsimp simp: Let_def split: rbt.splits color.splits)
apply (rule trans_less_add1)
apply (intro add_less_mono trans_less_add2
order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []
apply (clarsimp simp: Let_def split: rbt.splits color.splits)
apply (intro add_less_mono trans_less_add2
order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []
done
qed
lemmas [simp del] = compare_height.simps
lemma compare_height_alt:
"RBT_Impl.compare_height sx s t tx = compare_height sx s t tx"
apply (induct sx s t tx rule: compare_height.induct)
apply (subst RBT_Impl.compare_height.simps)
apply (subst compare_height.simps)
apply (auto split: rbt.split)
done
term RBT_Impl.skip_red
lemma param_skip_red[param]: "(RBT_Impl.skip_red,RBT_Impl.skip_red)
∈ ⟨Rk,Rv⟩rbt_rel → ⟨Rk,Rv⟩rbt_rel"
unfolding skip_red_alt[abs_def] by parametricity
lemma param_skip_black[param]: "(RBT_Impl.skip_black,RBT_Impl.skip_black)
∈ ⟨Rk,Rv⟩rbt_rel → ⟨Rk,Rv⟩rbt_rel"
unfolding RBT_Impl.skip_black_def[abs_def] by parametricity
term case_rbt
lemma param_case_rbt':
assumes "(t,t')∈⟨Rk,Rv⟩rbt_rel"
assumes "⟦t=rbt.Empty; t'=rbt.Empty⟧ ⟹ (fl,fl')∈R"
assumes "⋀c l k v r c' l' k' v' r'. ⟦
t = Branch c l k v r; t' = Branch c' l' k' v' r';
(c,c')∈color_rel;
(l,l')∈⟨Rk,Rv⟩rbt_rel; (k,k')∈Rk; (v,v')∈Rv; (r,r')∈⟨Rk,Rv⟩rbt_rel
⟧ ⟹ (fb c l k v r, fb' c' l' k' v' r') ∈ R"
shows "(case_rbt fl fb t, case_rbt fl' fb' t') ∈ R"
using assms by (auto split: rbt.split elim: rbt_rel_elims)
lemma compare_height_param_aux[param]:
"⟦ (sx,sx')∈⟨Rk,Rv⟩rbt_rel; (s,s')∈⟨Rk,Rv⟩rbt_rel;
(t,t')∈⟨Rk,Rv⟩rbt_rel; (tx,tx')∈⟨Rk,Rv⟩rbt_rel ⟧
⟹ (compare_height sx s t tx, compare_height sx' s' t' tx') ∈ compare_rel"
apply (induct sx' s' t' tx' arbitrary: sx s t tx
rule: compare_height.induct)
apply (subst (2) compare_height.simps)
apply (subst compare_height.simps)
apply (parametricity add: param_case_prod' param_case_rbt', (simp only: prod.inject)+) []
done
lemma compare_height_param[param]:
"(RBT_Impl.compare_height,RBT_Impl.compare_height) ∈
⟨Rk,Rv⟩rbt_rel → ⟨Rk,Rv⟩rbt_rel → ⟨Rk,Rv⟩rbt_rel → ⟨Rk,Rv⟩rbt_rel
→ compare_rel"
unfolding compare_height_alt[abs_def]
by parametricity
lemma rbt_rel_bheight: "(t, t') ∈ ⟨Ra, Rb⟩rbt_rel ⟹ bheight t = bheight t'"
by (induction t arbitrary: t') (auto elim!: rbt_rel_elims color_rel.cases)
lemma param_rbt_baliL[param]: "(rbt_baliL,rbt_baliL) ∈ ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 l l' a a' b b' r r')
thus ?case
apply (induct l a b r arbitrary: l' a' b' r' rule: rbt_baliL.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: rbt_baliL.simps)
apply parametricity+
done
qed
lemma param_rbt_baliR[param]: "(rbt_baliR,rbt_baliR) ∈ ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 l l' a a' b b' r r')
thus ?case
apply (induction l a b r arbitrary: l' a' b' r' rule: rbt_baliR.induct)
apply (elim_all rbt_rel_elims color_rel_elims)
apply (simp_all only: rbt_baliR.simps)
apply parametricity+
done
qed
lemma param_rbt_joinL[param]: "(rbt_joinL,rbt_joinL) ∈ ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 l l' a a' b b' r r')
thus ?case
proof (induction l a b r arbitrary: l' a' b' r' rule: rbt_joinL.induct)
case (1 l a b r)
have "bheight l < bheight r ⟹ r = RBT_Impl.MB ll k v rr ⟹ (ll, ll') ∈ ⟨Ra, Rb⟩rbt_rel ⟹
(k, k') ∈ Ra ⟹ (v, v') ∈ Rb ⟹ (rr, rr') ∈ ⟨Ra, Rb⟩rbt_rel ⟹
(rbt_baliL (rbt_joinL l a b ll) k v rr, rbt_baliL (rbt_joinL l' a' b' ll') k' v' rr') ∈ ⟨Ra, Rb⟩rbt_rel"
for ll ll' k k' v v' rr rr'
by parametricity (auto intro: 1)
then show ?case
using 1
by (auto simp: rbt_joinL.simps[of l a b r] rbt_joinL.simps[of l' a' b' r'] rbt_rel_bheight
intro: rbt_rel_intros color_rel.intros elim!: rbt_rel_elims color_rel_elims
split: rbt.splits color.splits)
qed
qed
lemma param_rbt_joinR[param]:
"(rbt_joinR,rbt_joinR) ∈ ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI, goal_cases)
case (1 l l' a a' b b' r r')
thus ?case
proof (induction l a b r arbitrary: l' a' b' r' rule: rbt_joinR.induct)
case (1 l a b r)
have "bheight r < bheight l ⟹ l = RBT_Impl.MB ll k v rr ⟹ (ll, ll') ∈ ⟨Ra, Rb⟩rbt_rel ⟹
(k, k') ∈ Ra ⟹ (v, v') ∈ Rb ⟹ (rr, rr') ∈ ⟨Ra, Rb⟩rbt_rel ⟹
(rbt_baliR ll k v (rbt_joinR rr a b r), rbt_baliR ll' k' v' (rbt_joinR rr' a' b' r')) ∈ ⟨Ra, Rb⟩rbt_rel"
for ll ll' k k' v v' rr rr'
by parametricity (auto intro: 1)
then show ?case
using 1
by (auto simp: rbt_joinR.simps[of l] rbt_joinR.simps[of l'] rbt_rel_bheight[symmetric]
intro: rbt_rel_intros color_rel.intros elim!: rbt_rel_elims color_rel_elims
split: rbt.splits color.splits)
qed
qed
lemma param_rbt_join[param]: "(rbt_join,rbt_join) ∈ ⟨Ra,Rb⟩rbt_rel → Ra → Rb → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
by (auto simp: rbt_join_def Let_def rbt_rel_bheight) parametricity+
lemma param_split[param]:
fixes less
assumes [param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_split less, ord.rbt_split less') ∈ ⟨Ra,Rb⟩rbt_rel → Ra → ⟨⟨Ra,Rb⟩rbt_rel,⟨⟨Rb⟩option_rel,⟨Ra,Rb⟩rbt_rel⟩prod_rel⟩prod_rel"
proof (intro fun_relI)
fix t t' a a'
assume "(t, t') ∈ ⟨Ra, Rb⟩rbt_rel" "(a, a') ∈ Ra"
then show "(ord.rbt_split less t a, ord.rbt_split less' t' a') ∈ ⟨⟨Ra,Rb⟩rbt_rel,⟨⟨Rb⟩option_rel,⟨Ra,Rb⟩rbt_rel⟩prod_rel⟩prod_rel"
proof (induction t a arbitrary: t' rule: ord.rbt_split.induct[where ?less=less])
case (2 c l k b r a)
obtain c' l' k' b' r' where t'_def: "t' = Branch c' l' k' b' r'"
using 2(3)
by (auto elim: rbt_rel_elims)
have sub_rel: "(l, l') ∈ ⟨Ra, Rb⟩rbt_rel" "(k, k') ∈ Ra" "(b, b') ∈ Rb" "(r, r') ∈ ⟨Ra, Rb⟩rbt_rel"
using 2(3)
by (auto simp: t'_def elim: rbt_rel_elims)
have less_iff: "less a k ⟷ less' a' k'" "less k a ⟷ less' k' a'"
using assms 2(4) sub_rel(2)
by (auto dest: fun_relD)
show ?case
using 2(1)[OF _ sub_rel(1) 2(4)] 2(2)[OF _ _ sub_rel(4) 2(4)] sub_rel
unfolding t'_def less_iff ord.rbt_split.simps(2)[of less c] ord.rbt_split.simps(2)[of less' c']
by (auto split: prod.splits) parametricity+
qed (auto simp: ord.rbt_split.simps elim!: rbt_rel_elims intro: rbt_rel_intros)
qed
lemma param_rbt_union_swap_rec[param]:
fixes less
assumes [param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_union_swap_rec less, ord.rbt_union_swap_rec less') ∈
(Ra → Rb → Rb → Rb) → Id → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
proof (intro fun_relI)
fix f f' b b' t1 t1' t2 t2'
assume "(f, f') ∈ Ra → Rb → Rb → Rb" "(b, b') ∈ bool_rel" "(t1, t1') ∈ ⟨Ra, Rb⟩rbt_rel" "(t2, t2') ∈ ⟨Ra, Rb⟩rbt_rel"
then show "(ord.rbt_union_swap_rec less f b t1 t2, ord.rbt_union_swap_rec less' f' b' t1' t2') ∈ ⟨Ra, Rb⟩rbt_rel"
proof (induction f b t1 t2 arbitrary: b' t1' t2' rule: ord.rbt_union_swap_rec.induct[where ?less=less])
case (1 f b t1 t2)
obtain γ s1 s2 where flip1: "(γ, s2, s1) =
(if flip_rbt t2 t1 then (¬b, t1, t2) else (b, t2, t1))"
by fastforce
obtain γ' s1' s2' where flip2: "(γ', s2', s1') =
(if flip_rbt t2' t1' then (¬b', t1', t2') else (b', t2', t1'))"
by fastforce
define g where "g = (if γ then λk v v'. f k v' v else f)"
define g' where "g' = (if γ' then λk v v'. f' k v' v else f')"
note bheight_cong = rbt_rel_bheight[OF 1(5)] rbt_rel_bheight[OF 1(6)]
have flip_cong: "flip_rbt t2 t1 ⟷ flip_rbt t2' t1'"
by (auto simp: flip_rbt_def bheight_cong)
have gamma_cong: "γ = γ'"
using flip1 flip2 1(4)
by (auto simp: flip_cong split: if_splits)
have small_rbt_cong: "small_rbt s2 ⟷ small_rbt s2'"
using flip1 flip2
by (auto simp: small_rbt_def flip_cong bheight_cong split: if_splits)
have rbt_rel_s: "(s1, s1') ∈ ⟨Ra, Rb⟩rbt_rel" "(s2, s2') ∈ ⟨Ra, Rb⟩rbt_rel"
using flip1 flip2 1(5,6)
by (auto simp: flip_cong split: if_splits)
have fun_rel_g: "(g, g') ∈ Ra → Rb → Rb → Rb"
using flip1 flip2 1(3,4)
by (auto simp: flip_cong g_def g'_def intro: fun_relD[OF fun_relD[OF fun_relD]] split: if_splits)
have rbt_rel_fold: "(RBT_Impl.fold (ord.rbt_insert_with_key less g) s2 s1, RBT_Impl.fold (ord.rbt_insert_with_key less' g') s2' s1') ∈ ⟨Ra, Rb⟩rbt_rel"
unfolding RBT_Impl.fold_def RBT_Impl.entries_def ord.rbt_insert_with_key_def
using rbt_rel_s fun_rel_g
by parametricity
{
fix c l k v r c' l' k' v' r' ll β rr ll' β' rr'
assume defs: "s1 = Branch c l k v r" "s1' = Branch c' l' k' v' r'"
"ord.rbt_split less s2 k = (ll, β, rr)" "ord.rbt_split less' s2' k' = (ll', β', rr')"
"¬small_rbt s2"
have split_rel: "(ord.rbt_split less s2 k, ord.rbt_split less' s2' k') ∈ ⟨⟨Ra,Rb⟩rbt_rel,⟨⟨Rb⟩option_rel,⟨Ra,Rb⟩rbt_rel⟩prod_rel⟩prod_rel"
using defs(1,2) param_split[OF assms, of Rb] rbt_rel_s
by (auto elim: rbt_rel_elims dest: fun_relD)
have IH1: "(ord.rbt_union_swap_rec less f γ l ll, ord.rbt_union_swap_rec less' f' γ' l' ll') ∈ ⟨Ra,Rb⟩rbt_rel"
apply (rule 1(1)[OF refl flip1 refl refl _ _ _ refl])
using 1(3) split_rel rbt_rel_s(1) defs
by (auto simp: gamma_cong elim: rbt_rel_elims)
have IH2: "(ord.rbt_union_swap_rec less f γ r rr, ord.rbt_union_swap_rec less' f' γ' r' rr') ∈ ⟨Ra,Rb⟩rbt_rel"
apply (rule 1(2)[OF refl flip1 refl refl _ _ _ refl])
using 1(3) split_rel rbt_rel_s(1) defs
by (auto simp: gamma_cong elim: rbt_rel_elims)
have fun_rel_g_app: "(g k v, g' k' v') ∈ Rb → Rb"
using fun_rel_g rbt_rel_s
by (auto simp: defs elim: rbt_rel_elims dest: fun_relD)
have "(rbt_join (ord.rbt_union_swap_rec less f γ l ll) k (case β of None ⇒ v | Some x ⇒ g k v x) (ord.rbt_union_swap_rec less f γ r rr),
rbt_join (ord.rbt_union_swap_rec less' f' γ' l' ll') k' (case β' of None ⇒ v' | Some x ⇒ g' k' v' x) (ord.rbt_union_swap_rec less' f' γ' r' rr')) ∈ ⟨Ra, Rb⟩rbt_rel"
apply parametricity
using IH1 IH2 rbt_rel_s fun_rel_g_app split_rel
by (auto simp: defs elim!: rbt_rel_elims)
}
then show ?case
unfolding ord.rbt_union_swap_rec.simps[of _ _ _ t1] ord.rbt_union_swap_rec.simps[of _ _ _ t1']
using rbt_rel_fold rbt_rel_s
by (auto simp: flip1[symmetric] flip2[symmetric] g_def[symmetric] g'_def[symmetric] small_rbt_cong
split: rbt.splits prod.splits elim: rbt_rel_elims)
qed
qed
lemma param_rbt_union[param]:
fixes less
assumes param_less[param]: "(less,less') ∈ Ra → Ra → Id"
shows "(ord.rbt_union less, ord.rbt_union less')
∈ ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel → ⟨Ra,Rb⟩rbt_rel"
unfolding ord.rbt_union_def[abs_def] ord.rbt_union_with_key_def[abs_def]
by parametricity
term rm_iterateoi
lemma param_rm_iterateoi[param]: "(rm_iterateoi,rm_iterateoi)
∈ ⟨Ra,Rb⟩rbt_rel → (Rc→Id) → (⟨Ra,Rb⟩prod_rel → Rc → Rc) → Rc → Rc"
unfolding rm_iterateoi_def
by (parametricity)
lemma param_rm_reverse_iterateoi[param]:
"(rm_reverse_iterateoi,rm_reverse_iterateoi)
∈ ⟨Ra,Rb⟩rbt_rel → (Rc→Id) → (⟨Ra,Rb⟩prod_rel → Rc → Rc) → Rc → Rc"
unfolding rm_reverse_iterateoi_def
by (parametricity)
lemma param_color_eq[param]:
"((=), (=))∈color_rel→color_rel→Id"
by (auto elim: color_rel.cases)
lemma param_color_of[param]:
"(color_of, color_of)∈⟨Rk,Rv⟩rbt_rel→color_rel"
unfolding color_of_def
by parametricity
term bheight
lemma param_bheight[param]:
"(bheight,bheight)∈⟨Rk,Rv⟩rbt_rel→Id"
unfolding bheight_def
by (parametricity)
lemma inv1_param[param]: "(inv1,inv1)∈⟨Rk,Rv⟩rbt_rel→Id"
unfolding inv1_def
by (parametricity)
lemma inv2_param[param]: "(inv2,inv2)∈⟨Rk,Rv⟩rbt_rel→Id"
unfolding inv2_def
by (parametricity)
term ord.rbt_less
lemma rbt_less_param[param]: "(ord.rbt_less,ord.rbt_less) ∈
(Rk→Rk→Id) → Rk → ⟨Rk,Rv⟩rbt_rel → Id"
unfolding ord.rbt_less_prop[abs_def]
apply (parametricity add: param_list_ball)
unfolding RBT_Impl.keys_def RBT_Impl.entries_def
apply (parametricity)
done
term ord.rbt_greater
lemma rbt_greater_param[param]: "(ord.rbt_greater,ord.rbt_greater) ∈
(Rk→Rk→Id) → Rk → ⟨Rk,Rv⟩rbt_rel → Id"
unfolding ord.rbt_greater_prop[abs_def]
apply (parametricity add: param_list_ball)
unfolding RBT_Impl.keys_def RBT_Impl.entries_def
apply (parametricity)
done
lemma rbt_sorted_param[param]:
"(ord.rbt_sorted,ord.rbt_sorted)∈(Rk→Rk→Id)→⟨Rk,Rv⟩rbt_rel→Id"
unfolding ord.rbt_sorted_def[abs_def]
by (parametricity)
lemma is_rbt_param[param]: "(ord.is_rbt,ord.is_rbt) ∈
(Rk→Rk→Id) → ⟨Rk,Rv⟩rbt_rel → Id"
unfolding ord.is_rbt_def[abs_def]
by (parametricity)
definition "rbt_map_rel' lt = br (ord.rbt_lookup lt) (ord.is_rbt lt)"
lemma (in linorder) rbt_map_impl:
"(rbt.Empty,Map.empty) ∈ rbt_map_rel' (<)"
"(rbt_insert,λk v m. m(k↦v))
∈ Id → Id → rbt_map_rel' (<) → rbt_map_rel' (<)"
"(rbt_lookup,λm k. m k) ∈ rbt_map_rel' (<) → Id → ⟨Id⟩option_rel"
"(rbt_delete,λk m. m|`(-{k})) ∈ Id → rbt_map_rel' (<) → rbt_map_rel' (<)"
"(rbt_union,(++))
∈ rbt_map_rel' (<) → rbt_map_rel' (<) → rbt_map_rel' (<)"
by (auto simp add:
rbt_lookup_rbt_insert rbt_lookup_rbt_delete rbt_lookup_rbt_union
rbt_union_is_rbt
rbt_map_rel'_def br_def)
lemma sorted_wrt_keys_true[simp]: "sorted_wrt (λ(_,_) (_,_). True) l"
apply (induct l)
apply auto
done
definition rbt_map_rel_def_internal:
"rbt_map_rel lt Rk Rv ≡ ⟨Rk,Rv⟩rbt_rel O rbt_map_rel' lt"
lemma rbt_map_rel_def:
"⟨Rk,Rv⟩rbt_map_rel lt ≡ ⟨Rk,Rv⟩rbt_rel O rbt_map_rel' lt"
by (simp add: rbt_map_rel_def_internal relAPP_def)
lemma (in linorder) autoref_gen_rbt_empty:
"(rbt.Empty,Map.empty) ∈ ⟨Rk,Rv⟩rbt_map_rel (<)"
by (auto simp: rbt_map_rel_def
intro!: rbt_map_impl rbt_rel_intros)
lemma (in linorder) autoref_gen_rbt_insert:
fixes less_impl
assumes param_less: "(less_impl,(<)) ∈ Rk → Rk → Id"
shows "(ord.rbt_insert less_impl,λk v m. m(k↦v)) ∈
Rk → Rv → ⟨Rk,Rv⟩rbt_map_rel (<) → ⟨Rk,Rv⟩rbt_map_rel (<)"
apply (intro fun_relI)
unfolding rbt_map_rel_def
apply (auto intro!: relcomp.intros)
apply (rule param_rbt_insert[OF param_less, param_fo])
apply assumption+
apply (rule rbt_map_impl[param_fo])
apply (rule IdI | assumption)+
done
lemma (in linorder) autoref_gen_rbt_lookup:
fixes less_impl
assumes param_less: "(less_impl,(<)) ∈ Rk → Rk → Id"
shows "(ord.rbt_lookup less_impl, λm k. m k) ∈
⟨Rk,Rv⟩rbt_map_rel (<) → Rk → ⟨Rv⟩option_rel"
unfolding rbt_map_rel_def
apply (intro fun_relI)
apply (elim relcomp.cases)
apply hypsubst
apply (subst R_O_Id[symmetric])
apply (rule relcompI)
apply (rule param_rbt_lookup[OF param_less, param_fo])
apply assumption+
apply (subst option_rel_id_simp[symmetric])
apply (rule rbt_map_impl[param_fo])
apply assumption
apply (rule IdI)
done
lemma (in linorder) autoref_gen_rbt_delete:
fixes less_impl
assumes param_less: "(less_impl,(<)) ∈ Rk → Rk → Id"
shows "(ord.rbt_delete less_impl, λk m. m |`(-{k})) ∈
Rk → ⟨Rk,Rv⟩rbt_map_rel (<) → ⟨Rk,Rv⟩rbt_map_rel (<)"
unfolding rbt_map_rel_def
apply (intro fun_relI)
apply (elim relcomp.cases)
apply hypsubst
apply (rule relcompI)
apply (rule param_rbt_delete[OF param_less, param_fo])
apply assumption+
apply (rule rbt_map_impl[param_fo])
apply (rule IdI)
apply assumption
done
lemma (in linorder) autoref_gen_rbt_union:
fixes less_impl
assumes param_less: "(less_impl,(<)) ∈ Rk → Rk → Id"
shows "(ord.rbt_union less_impl, (++)) ∈
⟨Rk,Rv⟩rbt_map_rel (<) → ⟨Rk,Rv⟩rbt_map_rel (<) → ⟨Rk,Rv⟩rbt_map_rel (<)"
unfolding rbt_map_rel_def
apply (intro fun_relI)
apply (elim relcomp.cases)
apply hypsubst
apply (rule relcompI)
apply (rule param_rbt_union[OF param_less, param_fo])
apply assumption+
apply (rule rbt_map_impl[param_fo])
apply assumption+
done
subsection ‹A linear ordering on red-black trees›
abbreviation "rbt_to_list t ≡ it_to_list rm_iterateoi t"
lemma (in linorder) rbt_to_list_correct:
assumes SORTED: "rbt_sorted t"
shows "rbt_to_list t = sorted_list_of_map (rbt_lookup t)" (is "?tl = _")
proof -
from map_it_to_list_linord_correct[where it=rm_iterateoi, OF
rm_iterateoi_correct[OF SORTED]
] have
M: "map_of ?tl = rbt_lookup t"
and D: "distinct (map fst ?tl)"
and S: "sorted (map fst ?tl)"
by (simp_all)
from the_sorted_list_of_map[OF D S] M show ?thesis
by simp
qed
definition
"cmp_rbt cmpk cmpv ≡ cmp_img rbt_to_list (cmp_lex (cmp_prod cmpk cmpv))"
lemma (in linorder) param_rbt_sorted_list_of_map[param]:
shows "(rbt_to_list, sorted_list_of_map) ∈
⟨Rk, Rv⟩rbt_map_rel (<) → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
apply (auto simp: rbt_map_rel_def rbt_map_rel'_def br_def
rbt_to_list_correct[symmetric]
)
by (parametricity)
lemma param_rbt_sorted_list_of_map'[param]:
assumes ELO: "eq_linorder cmp'"
shows "(rbt_to_list,linorder.sorted_list_of_map (comp2le cmp')) ∈
⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp') → ⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
by parametricity
qed
lemma rbt_linorder_impl:
assumes ELO: "eq_linorder cmp'"
assumes [param]: "(cmp,cmp')∈Rk→Rk→Id"
shows
"(cmp_rbt cmp, cmp_map cmp') ∈
(Rv→Rv→Id)
→ ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')
→ ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp') → Id"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
unfolding cmp_map_def[abs_def] cmp_rbt_def[abs_def]
apply (parametricity add: param_cmp_extend param_cmp_img)
unfolding rbt_map_rel_def[abs_def] rbt_map_rel'_def br_def
by auto
qed
lemma color_rel_sv[relator_props]: "single_valued color_rel"
by (auto intro!: single_valuedI elim: color_rel.cases)
lemma rbt_rel_sv_aux:
assumes SK: "single_valued Rk"
assumes SV: "single_valued Rv"
assumes I1: "(a,b)∈(⟨Rk, Rv⟩rbt_rel)"
assumes I2: "(a,c)∈(⟨Rk, Rv⟩rbt_rel)"
shows "b=c"
using I1 I2
apply (induct arbitrary: c)
apply (elim rbt_rel_elims)
apply simp
apply (elim rbt_rel_elims)
apply (simp add: single_valuedD[OF color_rel_sv]
single_valuedD[OF SK] single_valuedD[OF SV])
done
lemma rbt_rel_sv[relator_props]:
assumes SK: "single_valued Rk"
assumes SV: "single_valued Rv"
shows "single_valued (⟨Rk, Rv⟩rbt_rel)"
by (auto intro: single_valuedI rbt_rel_sv_aux[OF SK SV])
lemma rbt_map_rel_sv[relator_props]:
"⟦single_valued Rk; single_valued Rv⟧
⟹ single_valued (⟨Rk,Rv⟩rbt_map_rel lt)"
apply (auto simp: rbt_map_rel_def rbt_map_rel'_def)
apply (rule single_valued_relcomp)
apply (rule rbt_rel_sv, assumption+)
apply (rule br_sv)
done
lemmas [autoref_rel_intf] = REL_INTFI[of "rbt_map_rel x" i_map] for x
subsection ‹Second Part: Binding›
lemma autoref_rbt_empty[autoref_rules]:
assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
assumes [simplified,param]: "GEN_OP cmp cmp' (Rk→Rk→Id)"
shows "(rbt.Empty,op_map_empty) ∈
⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
by (simp) (rule autoref_gen_rbt_empty)
qed
lemma autoref_rbt_update[autoref_rules]:
assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
assumes [simplified,param]: "GEN_OP cmp cmp' (Rk→Rk→Id)"
shows "(ord.rbt_insert (comp2lt cmp),op_map_update) ∈
Rk→Rv→⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')
→ ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
unfolding op_map_update_def[abs_def]
apply (rule autoref_gen_rbt_insert)
unfolding comp2lt_def[abs_def]
by (parametricity)
qed
lemma autoref_rbt_lookup[autoref_rules]:
assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
assumes [simplified,param]: "GEN_OP cmp cmp' (Rk→Rk→Id)"
shows "(λk t. ord.rbt_lookup (comp2lt cmp) t k, op_map_lookup) ∈
Rk → ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp') → ⟨Rv⟩option_rel"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
unfolding op_map_lookup_def[abs_def]
apply (intro fun_relI)
apply (rule autoref_gen_rbt_lookup[param_fo])
apply (unfold comp2lt_def[abs_def]) []
apply (parametricity)
apply assumption+
done
qed
lemma autoref_rbt_delete[autoref_rules]:
assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
assumes [simplified,param]: "GEN_OP cmp cmp' (Rk→Rk→Id)"
shows "(ord.rbt_delete (comp2lt cmp),op_map_delete) ∈
Rk → ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')
→ ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
unfolding op_map_delete_def[abs_def]
apply (intro fun_relI)
apply (rule autoref_gen_rbt_delete[param_fo])
apply (unfold comp2lt_def[abs_def]) []
apply (parametricity)
apply assumption+
done
qed
lemma autoref_rbt_union[autoref_rules]:
assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
assumes [simplified,param]: "GEN_OP cmp cmp' (Rk→Rk→Id)"
shows "(ord.rbt_union (comp2lt cmp),(++)) ∈
⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp') → ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')
→ ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmp')"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
apply (intro fun_relI)
apply (rule autoref_gen_rbt_union[param_fo])
apply (unfold comp2lt_def[abs_def]) []
apply (parametricity)
apply assumption+
done
qed
lemma autoref_rbt_is_iterator[autoref_ga_rules]:
assumes ELO: "GEN_ALGO_tag (eq_linorder cmp')"
shows "is_map_to_sorted_list (comp2le cmp') Rk Rv (rbt_map_rel (comp2lt cmp'))
rbt_to_list"
proof -
interpret linorder "comp2le cmp'" "comp2lt cmp'"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
unfolding is_map_to_sorted_list_def
it_to_sorted_list_def
apply auto
proof -
fix r m'
assume "(r, m') ∈ ⟨Rk, Rv⟩rbt_map_rel (comp2lt cmp')"
then obtain r' where R1: "(r,r')∈⟨Rk,Rv⟩rbt_rel"
and R2: "(r',m') ∈ rbt_map_rel' (comp2lt cmp')"
unfolding rbt_map_rel_def by blast
from R2 have "is_rbt r'" and M': "m' = rbt_lookup r'"
unfolding rbt_map_rel'_def
by (simp_all add: br_def)
hence SORTED: "rbt_sorted r'"
by (simp add: is_rbt_def)
from map_it_to_list_linord_correct[where it = rm_iterateoi, OF
rm_iterateoi_correct[OF SORTED]
] have
M: "map_of (rbt_to_list r') = rbt_lookup r'"
and D: "distinct (map fst (rbt_to_list r'))"
and S: "sorted (map fst (rbt_to_list r'))"
by (simp_all)
show "∃l'. (rbt_to_list r, l') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel ∧
distinct l' ∧
map_to_set m' = set l' ∧
sorted_wrt (key_rel (comp2le cmp')) l'"
proof (intro exI conjI)
from D show "distinct (rbt_to_list r')" by (rule distinct_mapI)
from S show "sorted_wrt (key_rel (comp2le cmp')) (rbt_to_list r')"
unfolding key_rel_def[abs_def]
by simp
show "(rbt_to_list r, rbt_to_list r') ∈ ⟨⟨Rk, Rv⟩prod_rel⟩list_rel"
by (parametricity add: R1)
from M show "map_to_set m' = set (rbt_to_list r')"
by (simp add: M' map_of_map_to_set[OF D])
qed
qed
qed
lemmas [autoref_ga_rules] = class_to_eq_linorder
lemma (in linorder) dflt_cmp_id:
"(dflt_cmp (≤) (<), dflt_cmp (≤) (<))∈Id→Id→Id"
by auto
lemmas [autoref_rules] = dflt_cmp_id
lemma rbt_linorder_autoref[autoref_rules]:
assumes "SIDE_GEN_ALGO (eq_linorder cmpk')"
assumes "SIDE_GEN_ALGO (eq_linorder cmpv')"
assumes "GEN_OP cmpk cmpk' (Rk→Rk→Id)"
assumes "GEN_OP cmpv cmpv' (Rv→Rv→Id)"
shows
"(cmp_rbt cmpk cmpv, cmp_map cmpk' cmpv') ∈
⟨Rk,Rv⟩rbt_map_rel (comp2lt cmpk')
→ ⟨Rk,Rv⟩rbt_map_rel (comp2lt cmpk') → Id"
apply (intro fun_relI)
apply (rule rbt_linorder_impl[param_fo])
using assms
apply simp_all
done
lemma map_linorder_impl[autoref_ga_rules]:
assumes "GEN_ALGO_tag (eq_linorder cmpk)"
assumes "GEN_ALGO_tag (eq_linorder cmpv)"
shows "eq_linorder (cmp_map cmpk cmpv)"
using assms apply simp_all
using map_ord_eq_linorder .
lemma set_linorder_impl[autoref_ga_rules]:
assumes "GEN_ALGO_tag (eq_linorder cmpk)"
shows "eq_linorder (cmp_set cmpk)"
using assms apply simp_all
using set_ord_eq_linorder .
lemma (in linorder) rbt_map_rel_finite_aux:
"finite_map_rel (⟨Rk,Rv⟩rbt_map_rel (<))"
unfolding finite_map_rel_def
by (auto simp: rbt_map_rel_def rbt_map_rel'_def br_def)
lemma rbt_map_rel_finite[relator_props]:
assumes ELO: "GEN_ALGO_tag (eq_linorder cmpk)"
shows "finite_map_rel (⟨Rk,Rv⟩rbt_map_rel (comp2lt cmpk))"
proof -
interpret linorder "comp2le cmpk" "comp2lt cmpk"
using ELO by (simp add: eq_linorder_class_conv)
show ?thesis
using rbt_map_rel_finite_aux .
qed
abbreviation
"dflt_rm_rel ≡ rbt_map_rel (comp2lt (dflt_cmp (≤) (<)))"
lemmas [autoref_post_simps] = dflt_cmp_inv2 dflt_cmp_2inv
lemma [simp,autoref_post_simps]: "ord.rbt_ins (<) = rbt_ins"
proof (intro ext, goal_cases)
case (1 x xa xb xc) thus ?case
apply (induct x xa xb xc rule: rbt_ins.induct)
apply (simp_all add: ord.rbt_ins.simps)
done
qed
lemma [autoref_post_simps]: "ord.rbt_lookup ((<)::_::linorder⇒_) = rbt_lookup"
unfolding ord.rbt_lookup_def rbt_lookup_def ..
lemma [simp,autoref_post_simps]:
"ord.rbt_insert_with_key (<) = rbt_insert_with_key"
"ord.rbt_insert (<) = rbt_insert"
unfolding
ord.rbt_insert_with_key_def[abs_def] rbt_insert_with_key_def[abs_def]
ord.rbt_insert_def[abs_def] rbt_insert_def[abs_def]
by simp_all
lemma autoref_comp2eq[autoref_rules_raw]:
assumes PRIO_TAG_GEN_ALGO
assumes ELC: "SIDE_GEN_ALGO (eq_linorder cmp')"
assumes [simplified,param]: "GEN_OP cmp cmp' (R→R→Id)"
shows "(comp2eq cmp, (=)) ∈ R→R→Id"
proof -
from ELC have 1: "eq_linorder cmp'" by simp
show ?thesis
apply (subst eq_linorder_comp2eq_eq[OF 1,symmetric])
by parametricity
qed
lemma pi'_rm[icf_proper_iteratorI]:
"proper_it' rm_iterateoi rm_iterateoi"
"proper_it' rm_reverse_iterateoi rm_reverse_iterateoi"
apply (rule proper_it'I)
apply (rule pi_rm)
apply (rule proper_it'I)
apply (rule pi_rm_rev)
done
declare pi'_rm[proper_it]
lemmas autoref_rbt_rules =
autoref_rbt_empty
autoref_rbt_lookup
autoref_rbt_update
autoref_rbt_delete
autoref_rbt_union
lemmas autoref_rbt_rules_linorder[autoref_rules_raw] =
autoref_rbt_rules[where Rk="Rk"] for Rk :: "(_×_::linorder) set"
end
Theory Impl_Cfun_Set
section ‹Set by Characteristic Function›
theory Impl_Cfun_Set
imports "../Intf/Intf_Set"
begin
definition fun_set_rel where
fun_set_rel_internal_def:
"fun_set_rel R ≡ (R→bool_rel) O br Collect (λ_. True)"
lemma fun_set_rel_def: "⟨R⟩fun_set_rel = (R→bool_rel) O br Collect (λ_. True)"
by (simp add: relAPP_def fun_set_rel_internal_def)
lemma fun_set_rel_sv[relator_props]:
"⟦single_valued R; Range R = UNIV⟧ ⟹ single_valued (⟨R⟩fun_set_rel)"
unfolding fun_set_rel_def
by (tagged_solver (keep))
lemma fun_set_rel_RUNIV[relator_props]:
assumes SV: "single_valued R"
shows "Range (⟨R⟩fun_set_rel) = UNIV"
proof -
{
fix b
have "∃a. (a,b)∈⟨R⟩fun_set_rel" unfolding fun_set_rel_def
apply (rule exI)
apply (rule relcompI)
proof -
show "((λx. x∈b),b)∈br Collect (λ_. True)" by (auto simp: br_def)
show "(λx'. ∃x. (x',x)∈R ∧ x∈b,λx. x ∈ b)∈R → bool_rel"
by (auto dest: single_valuedD[OF SV])
qed
} thus ?thesis by blast
qed
lemmas [autoref_rel_intf] = REL_INTFI[of fun_set_rel i_set]
lemma fs_mem_refine[autoref_rules]: "(λx f. f x,(∈)) ∈ R → ⟨R⟩fun_set_rel → bool_rel"
apply (intro fun_relI)
apply (auto simp add: fun_set_rel_def br_def dest: fun_relD)
done
lemma fun_set_Collect_refine[autoref_rules]:
"(λx. x, Collect)∈(R→bool_rel) → ⟨R⟩fun_set_rel"
unfolding fun_set_rel_def
by (auto simp: br_def)
lemma fun_set_empty_refine[autoref_rules]:
"(λ_. False,{})∈⟨R⟩fun_set_rel"
by (force simp add: fun_set_rel_def br_def)
lemma fun_set_UNIV_refine[autoref_rules]:
"(λ_. True,UNIV)∈⟨R⟩fun_set_rel"
by (force simp add: fun_set_rel_def br_def)
lemma fun_set_union_refine[autoref_rules]:
"(λa b x. a x ∨ b x,(∪))∈⟨R⟩fun_set_rel → ⟨R⟩fun_set_rel → ⟨R⟩fun_set_rel"
proof -
have A: "⋀a b. (λx. x∈a ∨ x∈b, a ∪ b) ∈ br Collect (λ_. True)"
by (auto simp: br_def)
show ?thesis
apply (simp add: fun_set_rel_def)
apply (intro fun_relI)
apply clarsimp
apply rule
defer
apply (rule A)
apply (auto simp: br_def dest: fun_relD)
done
qed
lemma fun_set_inter_refine[autoref_rules]:
"(λa b x. a x ∧ b x,(∩))∈⟨R⟩fun_set_rel → ⟨R⟩fun_set_rel → ⟨R⟩fun_set_rel"
proof -
have A: "⋀a b. (λx. x∈a ∧ x∈b, a ∩ b) ∈ br Collect (λ_. True)"
by (auto simp: br_def)
show ?thesis
apply (simp add: fun_set_rel_def)
apply (intro fun_relI)
apply clarsimp
apply rule
defer
apply (rule A)
apply (auto simp: br_def dest: fun_relD)
done
qed
lemma fun_set_diff_refine[autoref_rules]:
"(λa b x. a x ∧ ¬b x,(-))∈⟨R⟩fun_set_rel → ⟨R⟩fun_set_rel → ⟨R⟩fun_set_rel"
proof -
have A: "⋀a b. (λx. x∈a ∧ ¬x∈b, a - b) ∈ br Collect (λ_. True)"
by (auto simp: br_def)
show ?thesis
apply (simp add: fun_set_rel_def)
apply (intro fun_relI)
apply clarsimp
apply rule
defer
apply (rule A)
apply (auto simp: br_def dest: fun_relD)
done
qed
end
Theory Impl_Array_Map
section ‹\isaheader{Array-Based Maps with Natural Number Keys}›
theory Impl_Array_Map
imports
Automatic_Refinement.Automatic_Refinement
"../../Lib/Diff_Array"
"../../Iterator/Iterator"
"../Gen/Gen_Map"
"../Intf/Intf_Comp"
"../Intf/Intf_Map"
begin
type_synonym 'v iam = "'v option array"
subsection ‹Definitions›
definition iam_α :: "'v iam ⇒ nat ⇀ 'v" where
"iam_α a i ≡ if i < array_length a then array_get a i else None"
lemma [code]: "iam_α a i ≡ array_get_oo None a i"
unfolding array_get_oo_def iam_α_def .
abbreviation iam_invar :: "'v iam ⇒ bool" where "iam_invar ≡ λ_. True"
definition iam_empty :: "unit ⇒ 'v iam"
where "iam_empty ≡ λ_::unit. array_of_list []"
definition iam_lookup :: "nat ⇒ 'v iam ⇀ 'v"
where [code_unfold]: "iam_lookup k a ≡ iam_α a k"
definition "iam_increment (l::nat) idx ≡
max (idx + 1 - l) (2 * l + 3)"
lemma incr_correct: "¬ idx < l ⟹ idx < l + iam_increment l idx"
unfolding iam_increment_def by auto
definition iam_update :: "nat ⇒ 'v ⇒ 'v iam ⇒ 'v iam"
where "iam_update k v a ≡ let
l = array_length a;
a = if k < l then a else array_grow a (iam_increment l k) None
in
array_set a k (Some v)"
lemma [code]: "iam_update k v a ≡ array_set_oo
(λ_. let l=array_length a in
array_set (array_grow a (iam_increment l k) None) k (Some v))
a k (Some v)"
unfolding iam_update_def array_set_oo_def
apply (rule eq_reflection)
by auto
definition iam_delete :: "nat ⇒ 'v iam ⇒ 'v iam"
where "iam_delete k a ≡
if k<array_length a then array_set a k None else a"
lemma [code]: "iam_delete k a ≡ array_set_oo (λ_. a) a k None"
unfolding iam_delete_def array_set_oo_def by auto
primrec iam_iteratei_aux
:: "nat ⇒ ('v iam) ⇒ ('σ⇒bool) ⇒ (nat × 'v⇒'σ⇒'σ) ⇒ 'σ ⇒ 'σ"
where
"iam_iteratei_aux 0 a c f σ = σ"
| "iam_iteratei_aux (Suc i) a c f σ = (
if c σ then
iam_iteratei_aux i a c f (
case array_get a i of None ⇒ σ | Some x ⇒ f (i, x) σ
)
else σ)"
definition iam_iteratei :: "'v iam ⇒ (nat × 'v,'σ) set_iterator" where
"iam_iteratei a = iam_iteratei_aux (array_length a) a"
subsection ‹Parametricity›
definition iam_rel_def_internal:
"iam_rel R ≡ ⟨⟨R⟩ option_rel⟩ array_rel"
lemma iam_rel_def: "⟨R⟩ iam_rel = ⟨⟨R⟩ option_rel⟩ array_rel"
by (simp add: iam_rel_def_internal relAPP_def)
lemma iam_rel_sv[relator_props]:
"single_valued Rv ⟹ single_valued (⟨Rv⟩iam_rel)"
unfolding iam_rel_def
by tagged_solver
lemma param_iam_α[param]:
"(iam_α, iam_α) ∈ ⟨R⟩ iam_rel → nat_rel → ⟨R⟩ option_rel"
unfolding iam_α_def[abs_def] iam_rel_def by parametricity
lemma param_iam_invar[param]:
"(iam_invar, iam_invar) ∈ ⟨R⟩ iam_rel → bool_rel"
unfolding iam_rel_def by parametricity
lemma param_iam_empty[param]:
"(iam_empty, iam_empty) ∈ unit_rel → ⟨R⟩iam_rel"
unfolding iam_empty_def[abs_def] iam_rel_def by parametricity
lemma param_iam_lookup[param]:
"(iam_lookup, iam_lookup) ∈ nat_rel → ⟨R⟩iam_rel → ⟨R⟩option_rel"
unfolding iam_lookup_def[abs_def]
by parametricity
lemma param_iam_increment[param]:
"(iam_increment, iam_increment) ∈ nat_rel → nat_rel → nat_rel"
unfolding iam_increment_def[abs_def]
by simp
lemma param_iam_update[param]:
"(iam_update, iam_update) ∈ nat_rel → R → ⟨R⟩iam_rel → ⟨R⟩iam_rel"
unfolding iam_update_def[abs_def] iam_rel_def Let_def
apply parametricity
done
lemma param_iam_delete[param]:
"(iam_delete, iam_delete) ∈ nat_rel → ⟨R⟩iam_rel → ⟨R⟩iam_rel"
unfolding iam_delete_def[abs_def] iam_rel_def by parametricity
lemma param_iam_iteratei_aux[param]:
assumes I: "i ≤ array_length a"
assumes IR: "(i,i') ∈ nat_rel"
assumes AR: "(a,a') ∈ ⟨Ra⟩iam_rel"
assumes CR: "(c,c') ∈ Rb → bool_rel"
assumes FR: "(f,f') ∈ ⟨nat_rel,Ra⟩prod_rel → Rb → Rb"
assumes σR: "(σ,σ') ∈ Rb"
shows "(iam_iteratei_aux i a c f σ, iam_iteratei_aux i' a' c' f' σ') ∈ Rb"
using assms
unfolding iam_rel_def
apply (induct i' arbitrary: i σ σ')
apply (simp_all only: pair_in_Id_conv iam_iteratei_aux.simps)
apply parametricity
apply simp_all
done
lemma param_iam_iteratei[param]:
"(iam_iteratei,iam_iteratei) ∈ ⟨Ra⟩iam_rel → (Rb → bool_rel) →
(⟨nat_rel,Ra⟩prod_rel → Rb → Rb) → Rb → Rb"
unfolding iam_iteratei_def[abs_def]
by parametricity (simp_all add: iam_rel_def)
subsection ‹Correctness›
definition "iam_rel' ≡ br iam_α iam_invar"
lemma iam_empty_correct:
"(iam_empty (), Map.empty) ∈ iam_rel'"
by (simp add: iam_rel'_def br_def iam_α_def[abs_def] iam_empty_def)
lemma iam_update_correct:
"(iam_update,op_map_update) ∈ nat_rel → Id → iam_rel' → iam_rel'"
by (auto simp: iam_rel'_def br_def Let_def array_get_array_set_other
incr_correct iam_α_def[abs_def] iam_update_def)
lemma iam_lookup_correct:
"(iam_lookup,op_map_lookup) ∈ Id → iam_rel' → ⟨Id⟩option_rel"
by (auto simp: iam_rel'_def br_def iam_lookup_def[abs_def])
lemma array_get_set_iff: "i<array_length a ⟹
array_get (array_set a i x) j = (if i=j then x else array_get a j)"
by (auto simp: array_get_array_set_other)
lemma iam_delete_correct:
"(iam_delete,op_map_delete) ∈ Id → iam_rel' → iam_rel'"
unfolding iam_α_def[abs_def] iam_delete_def[abs_def] iam_rel'_def br_def
by (auto simp: Let_def array_get_set_iff)
definition iam_map_rel_def_internal:
"iam_map_rel Rk Rv ≡
if Rk=nat_rel then ⟨Rv⟩iam_rel O iam_rel' else {}"
lemma iam_map_rel_def:
"⟨nat_rel,Rv⟩iam_map_rel ≡ ⟨Rv⟩iam_rel O iam_rel'"
unfolding iam_map_rel_def_internal relAPP_def by simp
lemmas [autoref_rel_intf] = REL_INTFI[of "iam_map_rel" i_map]
lemma iam_map_rel_sv[relator_props]:
"single_valued Rv ⟹ single_valued (⟨nat_rel,Rv⟩iam_map_rel)"
unfolding iam_map_rel_def iam_rel'_def by tagged_solver
lemma iam_empty_impl:
"(iam_empty (), op_map_empty) ∈ ⟨nat_rel,R⟩iam_map_rel"
unfolding iam_map_rel_def op_map_empty_def
apply (intro relcompI)
apply (rule param_iam_empty[THEN fun_relD], simp)
apply (rule iam_empty_correct)
done
lemma iam_lookup_impl:
"(iam_lookup, op_map_lookup)
∈ nat_rel → ⟨nat_rel,R⟩iam_map_rel → ⟨R⟩option_rel"
unfolding iam_map_rel_def
apply (intro fun_relI)
apply (elim relcompE)
apply (frule iam_lookup_correct[param_fo], assumption)
apply (frule param_iam_lookup[param_fo], assumption)
apply simp
done
lemma iam_update_impl:
"(iam_update, op_map_update) ∈
nat_rel → R → ⟨nat_rel,R⟩iam_map_rel → ⟨nat_rel,R⟩iam_map_rel"
unfolding iam_map_rel_def
apply (intro fun_relI, elim relcompEpair, intro relcompI)
apply (erule (2) param_iam_update[param_fo])
apply (rule iam_update_correct[param_fo])
apply simp_all
done
lemma iam_delete_impl:
"(iam_delete, op_map_delete) ∈
nat_rel → ⟨nat_rel,R⟩iam_map_rel → ⟨nat_rel,R⟩iam_map_rel"
unfolding iam_map_rel_def
apply (intro fun_relI, elim relcompEpair, intro relcompI)
apply (erule (1) param_iam_delete[param_fo])
apply (rule iam_delete_correct[param_fo])
by simp_all
lemmas iam_map_impl =
iam_empty_impl
iam_lookup_impl
iam_update_impl
iam_delete_impl
declare iam_map_impl[autoref_rules]
subsection ‹Iterator proofs›
abbreviation "iam_to_list a ≡ it_to_list iam_iteratei a"
lemma distinct_iam_to_list_aux:
shows "⟦distinct xs; ∀(i,_)∈set xs. i ≥ n⟧ ⟹
distinct (iam_iteratei_aux n a
(λ_.True) (λx y. y @ [x]) xs)"
(is "⟦_;_⟧ ⟹ distinct (?iam_to_list_aux n xs)")
proof (induction n arbitrary: xs)
case (0 xs) thus ?case by simp
next
case (Suc i xs)
show ?case
proof (cases "array_get a i")
case None
with Suc.IH[OF Suc.prems(1)] Suc.prems(2)
show ?thesis by force
next
case (Some x)
let ?xs' = "xs @ [(i,x)]"
from Suc.prems have "distinct ?xs'" and
"∀(i',x)∈set ?xs'. i' ≥ i" by force+
from Some and Suc.IH[OF this] show ?thesis by simp
qed
qed
lemma distinct_iam_to_list:
"distinct (iam_to_list a)"
unfolding it_to_list_def iam_iteratei_def
by (force intro: distinct_iam_to_list_aux)
lemma iam_to_list_set_correct_aux:
assumes "(a, m) ∈ iam_rel'"
shows "⟦n ≤ array_length a; map_to_set m - {(k,v). k < n} = set xs⟧
⟹ map_to_set m =
set (iam_iteratei_aux n a (λ_.True) (λx y. y @ [x]) xs)"
proof (induction n arbitrary: xs)
case (0 xs)
thus ?case by simp
next
case (Suc n xs)
with assms have [simp]: "array_get a n = m n"
unfolding iam_rel'_def br_def iam_α_def[abs_def] by simp
show ?case
proof (cases "m n")
case None
with Suc.prems(2) have "map_to_set m - {(k,v). k < n} = set xs"
unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
from None and Suc.IH[OF _ this] and Suc.prems(1)
show ?thesis by simp
next
case (Some x)
let ?xs' = "xs @ [(n,x)]"
from Some and Suc.prems(2)
have "map_to_set m - {(k,v). k < n} = set ?xs'"
unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
from Some and Suc.IH[OF _ this] and Suc.prems(1)
show ?thesis by simp
qed
qed
lemma iam_to_list_set_correct:
assumes "(a, m) ∈ iam_rel'"
shows "map_to_set m = set (iam_to_list a)"
proof-
from assms
have A: "map_to_set m - {(k, v). k < array_length a} = set []"
unfolding map_to_set_def iam_rel'_def br_def iam_α_def[abs_def]
by (force split: if_split_asm)
with iam_to_list_set_correct_aux[OF assms _ A] show ?thesis
unfolding it_to_list_def iam_iteratei_def by simp
qed
lemma iam_iteratei_aux_append:
"n ≤ length xs ⟹ iam_iteratei_aux n (Array (xs @ ys)) =
iam_iteratei_aux n (Array xs)"
apply (induction n)
apply force
apply (intro ext, auto split: option.split simp: nth_append)
done
lemma iam_iteratei_append:
"iam_iteratei (Array (xs @ [None])) c f σ =
iam_iteratei (Array xs) c f σ"
"iam_iteratei (Array (xs @ [Some x])) c f σ =
iam_iteratei (Array xs) c f
(if c σ then (f (length xs, x) σ) else σ)"
unfolding iam_iteratei_def
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force simp: nth_append iam_iteratei_aux_append) []
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force split: option.split
simp: nth_append iam_iteratei_aux_append) []
done
lemma iam_iteratei_aux_Cons:
"n < array_length a ⟹
iam_iteratei_aux n a (λ_. True) (λx l. l @ [x]) (x#xs) =
x # iam_iteratei_aux n a (λ_. True) (λx l. l @ [x]) xs"
by (induction n arbitrary: xs, auto split: option.split)
lemma iam_to_list_append:
"iam_to_list (Array (xs @ [None])) = iam_to_list (Array xs)"
"iam_to_list (Array (xs @ [Some x])) =
(length xs, x) # iam_to_list (Array xs)"
unfolding it_to_list_def iam_iteratei_def
apply (simp add: iam_iteratei_aux_append)
apply (simp add: iam_iteratei_aux_Cons)
apply (simp add: iam_iteratei_aux_append)
done
lemma autoref_iam_is_iterator[autoref_ga_rules]:
shows "is_map_to_list nat_rel Rv iam_map_rel iam_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
fix a m'
assume "(a,m') ∈ ⟨nat_rel,Rv⟩iam_map_rel"
then obtain a' where [param]: "(a,a')∈⟨Rv⟩iam_rel"
and "(a',m')∈iam_rel'" unfolding iam_map_rel_def by blast
have "(iam_to_list a, iam_to_list a')
∈ ⟨⟨nat_rel, Rv⟩prod_rel⟩list_rel" by parametricity
moreover from distinct_iam_to_list and
iam_to_list_set_correct[OF ‹(a',m')∈iam_rel'›]
have "RETURN (iam_to_list a') ≤ it_to_sorted_list
(key_rel (λ_ _. True)) (map_to_set m')"
unfolding it_to_sorted_list_def key_rel_def[abs_def]
by (force intro: refine_vcg)
ultimately show "∃l'. (iam_to_list a, l') ∈
⟨⟨nat_rel, Rv⟩prod_rel⟩list_rel
∧ RETURN l' ≤ it_to_sorted_list (
key_rel (λ_ _. True)) (map_to_set m')" by blast
qed
lemmas [autoref_ga_rules] =
autoref_iam_is_iterator[unfolded is_map_to_list_def]
lemma iam_iteratei_altdef:
"iam_iteratei a = foldli (iam_to_list a)"
(is "?f a = ?g (iam_to_list a)")
proof-
obtain l where "a = Array l" by (cases a)
have "?f (Array l) = ?g (iam_to_list (Array l))"
proof (induction "length l" arbitrary: l)
case (0 l)
thus ?case by (intro ext,
simp add: iam_iteratei_def it_to_list_def)
next
case (Suc n l)
hence "l ≠ []" and [simp]: "length l = Suc n" by force+
with append_butlast_last_id have [simp]:
"butlast l @ [last l] = l" by simp
with Suc have [simp]: "length (butlast l) = n" by simp
note IH = Suc(1)[OF this[symmetric]]
let ?l' = "iam_to_list (Array l)"
show ?case
proof (cases "last l")
case None
have "?f (Array l) =
?f (Array (butlast l @ [last l]))" by simp
also have "... = ?g (iam_to_list (Array (butlast l)))"
by (force simp: None iam_iteratei_append IH)
also have "iam_to_list (Array (butlast l)) =
iam_to_list (Array (butlast l @ [last l]))"
using None by (simp add: iam_to_list_append)
finally show "?f (Array l) = ?g ?l'" by simp
next
case (Some x)
have "?f (Array l) =
?f (Array (butlast l @ [last l]))" by simp
also have "... = ?g (iam_to_list
(Array (butlast l @ [last l])))"
by (force simp: IH iam_iteratei_append
iam_to_list_append Some)
finally show ?thesis by simp
qed
qed
thus ?thesis by (simp add: ‹a = Array l›)
qed
lemma pi_iam[icf_proper_iteratorI]:
"proper_it (iam_iteratei a) (iam_iteratei a)"
unfolding proper_it_def by (force simp: iam_iteratei_altdef)
lemma pi'_iam[icf_proper_iteratorI]:
"proper_it' iam_iteratei iam_iteratei"
by (rule proper_it'I, rule pi_iam)
end
Theory Impl_Bit_Set
section "Bitvector based Sets of Naturals"
theory Impl_Bit_Set
imports
"../../Iterator/Iterator"
"../Intf/Intf_Set"
Native_Word.Bits_Integer
begin
text ‹
Based on the Native-Word library, using bit-operations on arbitrary
precision integers. Fast for sets of small numbers,
direct and fast implementations of equal, union, inter, diff.
Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are
rather inefficient. Use MLton instead, here they are efficiently implemented.
›
type_synonym bitset = integer
definition bs_α :: "bitset ⇒ nat set" where "bs_α s ≡ { n . bit s n}"
context includes integer.lifting begin
definition bs_empty :: "unit ⇒ bitset" where "bs_empty ≡ λ_. 0"
lemma bs_empty_correct: "bs_α (bs_empty ()) = {}"
unfolding bs_α_def bs_empty_def
apply transfer
by auto
definition bs_isEmpty :: "bitset ⇒ bool" where "bs_isEmpty s ≡ s=0"
lemma bs_isEmpty_correct: "bs_isEmpty s ⟷ bs_α s = {}"
unfolding bs_isEmpty_def bs_α_def
by transfer (auto simp: bin_eq_iff)
term set_bit
definition bs_insert :: "nat ⇒ bitset ⇒ bitset" where
"bs_insert i s ≡ set_bit s i True"
lemma bs_insert_correct: "bs_α (bs_insert i s) = insert i (bs_α s)"
unfolding bs_α_def bs_insert_def
apply transfer
apply auto
apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
by (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
definition bs_delete :: "nat ⇒ bitset ⇒ bitset" where
"bs_delete i s ≡ set_bit s i False"
lemma bs_delete_correct: "bs_α (bs_delete i s) = (bs_α s) - {i}"
unfolding bs_α_def bs_delete_def
apply transfer
apply auto
apply (metis bin_nth_ops(1) int_set_bit_False_conv_NAND)
apply (metis (full_types) bin_nth_sc set_bit_int_def)
by (metis (full_types) bin_nth_sc_gen set_bit_int_def)
definition bs_mem :: "nat ⇒ bitset ⇒ bool" where
"bs_mem i s ≡ bit s i"
lemma bs_mem_correct: "bs_mem i s ⟷ i∈bs_α s"
unfolding bs_mem_def bs_α_def by transfer auto
definition bs_eq :: "bitset ⇒ bitset ⇒ bool" where
"bs_eq s1 s2 ≡ (s1=s2)"
lemma bs_eq_correct: "bs_eq s1 s2 ⟷ bs_α s1 = bs_α s2"
unfolding bs_eq_def bs_α_def
including integer.lifting
apply transfer
apply auto
by (metis bin_eqI mem_Collect_eq)
definition bs_subset_eq :: "bitset ⇒ bitset ⇒ bool" where
"bs_subset_eq s1 s2 ≡ s1 AND NOT s2 = 0"
lemma bs_subset_eq_correct: "bs_subset_eq s1 s2 ⟷ bs_α s1 ⊆ bs_α s2"
unfolding bs_α_def bs_subset_eq_def
by transfer (auto simp add: bit_eq_iff bin_nth_ops)
definition bs_disjoint :: "bitset ⇒ bitset ⇒ bool" where
"bs_disjoint s1 s2 ≡ s1 AND s2 = 0"
lemma bs_disjoint_correct: "bs_disjoint s1 s2 ⟷ bs_α s1 ∩ bs_α s2 = {}"
unfolding bs_α_def bs_disjoint_def
by transfer (auto simp add: bit_eq_iff bin_nth_ops)
definition bs_union :: "bitset ⇒ bitset ⇒ bitset" where
"bs_union s1 s2 = s1 OR s2"
lemma bs_union_correct: "bs_α (bs_union s1 s2) = bs_α s1 ∪ bs_α s2"
unfolding bs_α_def bs_union_def
by transfer (auto simp: bin_nth_ops)
definition bs_inter :: "bitset ⇒ bitset ⇒ bitset" where
"bs_inter s1 s2 = s1 AND s2"
lemma bs_inter_correct: "bs_α (bs_inter s1 s2) = bs_α s1 ∩ bs_α s2"
unfolding bs_α_def bs_inter_def
by transfer (auto simp: bin_nth_ops)
definition bs_diff :: "bitset ⇒ bitset ⇒ bitset" where
"bs_diff s1 s2 = s1 AND NOT s2"
lemma bs_diff_correct: "bs_α (bs_diff s1 s2) = bs_α s1 - bs_α s2"
unfolding bs_α_def bs_diff_def
by transfer (auto simp: bin_nth_ops)
definition bs_UNIV :: "unit ⇒ bitset" where "bs_UNIV ≡ λ_. -1"
lemma bs_UNIV_correct: "bs_α (bs_UNIV ()) = UNIV"
unfolding bs_α_def bs_UNIV_def
by transfer (auto)
definition bs_complement :: "bitset ⇒ bitset" where
"bs_complement s = NOT s"
lemma bs_complement_correct: "bs_α (bs_complement s) = - bs_α s"
unfolding bs_α_def bs_complement_def
by transfer (auto simp: bin_nth_ops)
end
lemmas bs_correct[simp] =
bs_empty_correct
bs_isEmpty_correct
bs_insert_correct
bs_delete_correct
bs_mem_correct
bs_eq_correct
bs_subset_eq_correct
bs_disjoint_correct
bs_union_correct
bs_inter_correct
bs_diff_correct
bs_UNIV_correct
bs_complement_correct
subsection ‹Autoref Setup›
definition bs_set_rel_def_internal:
"bs_set_rel Rk ≡
if Rk=nat_rel then br bs_α (λ_. True) else {}"
lemma bs_set_rel_def:
"⟨nat_rel⟩bs_set_rel ≡ br bs_α (λ_. True)"
unfolding bs_set_rel_def_internal relAPP_def by simp
lemmas [autoref_rel_intf] = REL_INTFI[of "bs_set_rel" i_set]
lemma bs_set_rel_sv[relator_props]: "single_valued (⟨nat_rel⟩bs_set_rel)"
unfolding bs_set_rel_def by auto
term bs_empty
lemma [autoref_rules]: "(bs_empty (),{})∈⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_UNIV (),UNIV)∈⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)∈⟨nat_rel⟩bs_set_rel → bool_rel"
by (auto simp: bs_set_rel_def br_def)
term insert
lemma [autoref_rules]: "(bs_insert,insert)∈nat_rel → ⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
term op_set_delete
lemma [autoref_rules]: "(bs_delete,op_set_delete)∈nat_rel → ⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_mem,(∈))∈nat_rel → ⟨nat_rel⟩bs_set_rel → bool_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_eq,(=))∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel → bool_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_subset_eq,(⊆))∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel → bool_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_union,(∪))∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_inter,(∩))∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_diff,(-))∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_complement,uminus)∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel"
by (auto simp: bs_set_rel_def br_def)
lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)∈⟨nat_rel⟩bs_set_rel → ⟨nat_rel⟩bs_set_rel → bool_rel"
by (auto simp: bs_set_rel_def br_def)
export_code
bs_empty
bs_isEmpty
bs_insert
bs_delete
bs_mem
bs_eq
bs_subset_eq
bs_disjoint
bs_union
bs_inter
bs_diff
bs_UNIV
bs_complement
in SML
end
Theory Impl_Uv_Set
theory Impl_Uv_Set
imports
"../../Iterator/Iterator"
"../Intf/Intf_Set"
Native_Word.Uint
begin
subsection ‹Bit-Vectors as Lists of Words›
subsubsection ‹Lookup›
primrec lookup :: "nat ⇒ ('a::len) word list ⇒ bool" where
"lookup _ [] ⟷ False"
| "lookup n (w#ws)
⟷ (if n<LENGTH('a) then test_bit w n else lookup (n-LENGTH('a)) ws)"
lemma lookup_append[simp]: "lookup n (w1@w2 :: 'a::len word list)
⟷ (
if n < LENGTH('a) * length w1 then
lookup n w1
else lookup (n - LENGTH('a) * length w1) w2)"
by (induction w1 arbitrary: n) auto
lemma lookup_zeroes[simp]: "lookup i (replicate n (0::'a::len word)) = False"
by (induction n arbitrary: i) auto
lemma lookup_out_of_bound:
fixes uv :: "'a::len word list"
assumes "¬ i < LENGTH('a::len) * length uv"
shows "¬ lookup i uv"
using assms
by (induction uv arbitrary: i) auto
subsubsection ‹Empty›
definition empty :: "'a::len word list" where "empty = []"
subsubsection ‹Set and Reset Bit›
function single_bit :: "nat ⇒ ('a::len) word list"
where "single_bit n = (
if (n<LENGTH('a)) then
[set_bit 0 n True]
else 0#single_bit (n-LENGTH('a)))"
by pat_completeness auto
termination
apply (relation "measure id")
apply simp
apply (simp add: not_less less_diff_conv2)
done
declare single_bit.simps[simp del]
lemma lookup_single_bit[simp]: "lookup i ((single_bit n)::'a::len word list) ⟷ i = n"
apply (induction n arbitrary: i rule: single_bit.induct)
apply (subst single_bit.simps)
apply (auto simp: bin_nth_sc_gen)
done
primrec set_bit :: "nat ⇒ 'a::len word list ⇒ 'a::len word list" where
"set_bit i [] = single_bit i"
| "set_bit i (w#ws) = (
if i<LENGTH('a) then
Bit_Operations.set_bit i w # ws
else
w # set_bit (i - LENGTH('a)) ws)"
lemma set_bit_lookup[simp]: "lookup i (set_bit j ws) ⟷ (lookup i ws ∨ i=j)"
apply (induction ws arbitrary: i j)
apply (auto simp add: test_bit_eq_bit word_size ring_bit_operations_class.bit_set_bit_iff)
done
primrec reset_bit :: "nat ⇒ 'a::len word list ⇒ 'a::len word list" where
"reset_bit i [] = []"
| "reset_bit i (w#ws) = (
if i<LENGTH('a) then
unset_bit i w # ws
else
w # reset_bit (i - LENGTH('a)) ws)"
lemma reset_bit_lookup[simp]: "lookup i (reset_bit j ws) ⟷ (lookup i ws ∧ i≠j)"
apply (induction ws arbitrary: i j)
apply (auto simp: test_bit_eq_bit word_size bit_unset_bit_iff)
done
subsubsection ‹Binary Operations›
definition
is_bin_op_impl
:: "(bool⇒bool⇒bool) ⇒ ('a::len word ⇒ 'a::len word ⇒ 'a::len word) ⇒ bool"
where "is_bin_op_impl f g ≡
(∀w v. ∀i<LENGTH('a). test_bit (g w v) i ⟷ f (test_bit w i) (test_bit v i))"
definition "is_strict_bin_op_impl f g ≡ is_bin_op_impl f g ∧ f False False = False"
fun binary :: "('a::len word ⇒ 'a::len word ⇒ 'a::len word)
⇒ 'a::len word list ⇒ 'a::len word list ⇒ 'a::len word list"
where
"binary f [] [] = []"
| "binary f [] (w#ws) = f 0 w # binary f [] ws"
| "binary f (v#vs) [] = f v 0 # binary f vs []"
| "binary f (v#vs) (w#ws) = f v w # binary f vs ws"
lemma binary_lookup:
assumes "is_strict_bin_op_impl f g"
shows "lookup i (binary g ws vs) ⟷ f (lookup i ws) (lookup i vs)"
using assms
apply (induction g ws vs arbitrary: i rule: binary.induct)
apply (auto simp: is_strict_bin_op_impl_def is_bin_op_impl_def)
done
subsection ‹Abstraction to Sets of Naturals›
definition "α uv ≡ {n. lookup n uv}"
lemma memb_correct: "lookup i ws ⟷ i∈α ws"
by (auto simp: α_def)
lemma empty_correct: "α empty = {}"
by (simp add: α_def empty_def)
lemma single_bit_correct: "α (single_bit n) = {n}"
by (simp add: α_def)
lemma insert_correct: "α (set_bit i ws) = Set.insert i (α ws)"
by (auto simp add: α_def)
lemma delete_correct: "α (reset_bit i ws) = (α ws) - {i}"
by (auto simp add: α_def)
lemma binary_correct:
assumes "is_strict_bin_op_impl f g"
shows "α (binary g ws vs) = { i . f (i∈α ws) (i∈α vs) }"
unfolding α_def
by (auto simp add: binary_lookup[OF assms])
fun union :: "'a::len word list ⇒ 'a::len word list ⇒ 'a::len word list"
where
"union [] ws = ws"
| "union vs [] = vs"
| "union (v#vs) (w#ws) = (v OR w) # union vs ws"
lemma union_lookup[simp]:
fixes vs :: "'a::len word list"
shows "lookup i (union vs ws) ⟷ lookup i vs ∨ lookup i ws"
apply (induction vs ws arbitrary: i rule: union.induct)
apply (auto simp: word_ao_nth)
done
lemma union_correct: "α (union ws vs) = α ws ∪ α vs"
by (auto simp add: α_def)
fun inter :: "'a::len word list ⇒ 'a::len word list ⇒ 'a::len word list"
where
"inter [] ws = []"
| "inter vs [] = []"
| "inter (v#vs) (w#ws) = (v AND w) # inter vs ws"
lemma inter_lookup[simp]:
fixes vs :: "'a::len word list"
shows "lookup i (inter vs ws) ⟷ lookup i vs ∧ lookup i ws"
apply (induction vs ws arbitrary: i rule: inter.induct)
apply (auto simp: word_ao_nth)
done
lemma inter_correct: "α (inter ws vs) = α ws ∩ α vs"
by (auto simp add: α_def)
fun diff :: "'a::len word list ⇒ 'a::len word list ⇒ 'a::len word list"
where
"diff [] ws = []"
| "diff vs [] = vs"
| "diff (v#vs) (w#ws) = (v AND NOT w) # diff vs ws"
lemma diff_lookup[simp]:
fixes vs :: "'a::len word list"
shows "lookup i (diff vs ws) ⟷ lookup i vs - lookup i ws"
apply (induction vs ws arbitrary: i rule: diff.induct)
apply (auto simp: word_ops_nth_size word_size)
done
lemma diff_correct: "α (diff ws vs) = α ws - α vs"
by (auto simp add: α_def)
fun zeroes :: "'a::len word list ⇒ bool" where
"zeroes [] ⟷ True"
| "zeroes (w#ws) ⟷ w=0 ∧ zeroes ws"
lemma zeroes_lookup: "zeroes ws ⟷ (∀i. ¬lookup i ws)"
apply (induction ws)
apply (auto simp: word_eq_iff)
by (metis diff_add_inverse2 not_add_less2)
lemma isEmpty_correct: "zeroes ws ⟷ α ws = {}"
by (auto simp: zeroes_lookup α_def)
fun equal :: "'a::len word list ⇒ 'a::len word list ⇒ bool" where
"equal [] [] ⟷ True"
| "equal [] ws ⟷ zeroes ws"
| "equal vs [] ⟷ zeroes vs"
| "equal (v#vs) (w#ws) ⟷ v=w ∧ equal vs ws"
lemma equal_lookup:
fixes vs ws :: "'a::len word list"
shows "equal vs ws ⟷ (∀i. lookup i vs = lookup i ws)"
proof (induction vs ws rule: equal.induct)
fix v w and vs ws :: "'a::len word list"
assume IH: "equal vs ws = (∀i. lookup i vs = lookup i ws)"
show "equal (v # vs) (w # ws) = (∀i. lookup i (v # vs) = lookup i (w # ws))"
proof (rule iffI, rule allI)
fix i
assume "equal (v#vs) (w#ws)"
thus "lookup i (v # vs) = lookup i (w # ws)"
by (auto simp: IH)
next
assume "∀i. lookup i (v # vs) = lookup i (w # ws)"
thus "equal (v # vs) (w # ws)"
apply (auto simp: word_eq_iff IH)
apply metis
apply metis
apply (drule_tac x="i + LENGTH('a)" in spec)
apply auto []
apply (drule_tac x="i + LENGTH('a)" in spec)
apply auto []
done
qed
qed (auto simp: zeroes_lookup)
lemma equal_correct: "equal vs ws ⟷ α vs = α ws"
by (auto simp: α_def equal_lookup)
fun subseteq :: "'a::len word list ⇒ 'a::len word list ⇒ bool" where
"subseteq [] ws ⟷ True"
| "subseteq vs [] ⟷ zeroes vs"
| "subseteq (v#vs) (w#ws) ⟷ (v AND NOT w = 0) ∧ subseteq vs ws"
lemma subseteq_lookup:
fixes vs ws :: "'a::len word list"
shows "subseteq vs ws ⟷ (∀i. lookup i vs ⟶ lookup i ws)"
apply (induction vs ws rule: subseteq.induct)
apply simp
apply (auto simp: zeroes_lookup) []
apply (auto simp: word_ops_nth_size word_size word_eq_iff)
by (metis diff_add_inverse2 not_add_less2)
lemma subseteq_correct: "subseteq vs ws ⟷ α vs ⊆ α ws"
by (auto simp: α_def subseteq_lookup)
fun subset :: "'a::len word list ⇒ 'a::len word list ⇒ bool" where
"subset [] ws ⟷ ¬zeroes ws"
| "subset vs [] ⟷ False"
| "subset (v#vs) (w#ws) ⟷ (if v=w then subset vs ws else subseteq (v#vs) (w#ws))"
lemma subset_lookup:
fixes vs ws :: "'a::len word list"
shows "subset vs ws ⟷ ((∀i. lookup i vs ⟶ lookup i ws)
∧ (∃i. ¬lookup i vs ∧ lookup i ws))"
apply (induction vs ws rule: subset.induct)
apply (simp add: zeroes_lookup)
apply (simp add: zeroes_lookup) []
apply (simp del: subseteq_correct add: subseteq_lookup)
apply safe
apply simp_all
apply (auto simp: word_ops_nth_size word_size word_eq_iff)
done
lemma subset_correct: "subset vs ws ⟷ α vs ⊂ α ws"
by (auto simp: α_def subset_lookup)
fun disjoint :: "'a::len word list ⇒ 'a::len word list ⇒ bool" where
"disjoint [] ws ⟷ True"
| "disjoint vs [] ⟷ True"
| "disjoint (v#vs) (w#ws) ⟷ (v AND w = 0) ∧ disjoint vs ws"
lemma disjoint_lookup:
fixes vs ws :: "'a::len word list"
shows "disjoint vs ws ⟷ (∀i. ¬(lookup i vs ∧ lookup i ws))"
apply (induction vs ws rule: disjoint.induct)
apply simp
apply simp
apply (auto simp: word_ops_nth_size word_size word_eq_iff)
by (metis diff_add_inverse2 not_add_less2)
lemma disjoint_correct: "disjoint vs ws ⟷ α vs ∩ α ws = {}"
by (auto simp: α_def disjoint_lookup)
subsection ‹Lifting to Uint›
type_synonym uint_vector = "uint list"
lift_definition uv_α :: "uint_vector ⇒ nat set" is α .
lift_definition uv_lookup :: "nat ⇒ uint_vector ⇒ bool" is lookup .
lift_definition uv_empty :: "uint_vector" is empty .
lift_definition uv_single_bit :: "nat ⇒ uint_vector" is single_bit .
lift_definition uv_set_bit :: "nat ⇒ uint_vector ⇒ uint_vector" is set_bit .
lift_definition uv_reset_bit :: "nat ⇒ uint_vector ⇒ uint_vector" is reset_bit .
lift_definition uv_union :: "uint_vector ⇒ uint_vector ⇒ uint_vector" is union .
lift_definition uv_inter :: "uint_vector ⇒ uint_vector ⇒ uint_vector" is inter .
lift_definition uv_diff :: "uint_vector ⇒ uint_vector ⇒ uint_vector" is diff .
lift_definition uv_zeroes :: "uint_vector ⇒ bool" is zeroes .
lift_definition uv_equal :: "uint_vector ⇒ uint_vector ⇒ bool" is equal .
lift_definition uv_subseteq :: "uint_vector ⇒ uint_vector ⇒ bool" is subseteq .
lift_definition uv_subset :: "uint_vector ⇒ uint_vector ⇒ bool" is subset .
lift_definition uv_disjoint :: "uint_vector ⇒ uint_vector ⇒ bool" is disjoint .
lemmas uv_memb_correct = memb_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_empty_correct = empty_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_single_bit_correct = single_bit_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_insert_correct = insert_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_delete_correct = delete_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_union_correct = union_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_inter_correct = inter_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_diff_correct = diff_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_isEmpty_correct = isEmpty_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_equal_correct = equal_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_subseteq_correct = subseteq_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_subset_correct = subset_correct[where 'a=dflt_size, Transfer.transferred]
lemmas uv_disjoint_correct = disjoint_correct[where 'a=dflt_size, Transfer.transferred]
lemmas [where 'a=dflt_size, Transfer.transferred, code] =
lookup.simps
empty_def
single_bit.simps
set_bit.simps
reset_bit.simps
union.simps
inter.simps
diff.simps
zeroes.simps
equal.simps
subseteq.simps
subset.simps
disjoint.simps
hide_const (open) α lookup empty single_bit set_bit reset_bit union inter diff zeroes
equal subseteq subset disjoint
subsection ‹Autoref Setup›
definition uv_set_rel_def_internal:
"uv_set_rel Rk ≡
if Rk=nat_rel then br uv_α (λ_. True) else {}"
lemma uv_set_rel_def:
"⟨nat_rel⟩uv_set_rel ≡ br uv_α (λ_. True)"
unfolding uv_set_rel_def_internal relAPP_def by simp
lemmas [autoref_rel_intf] = REL_INTFI[of "uv_set_rel" i_set]
lemma uv_set_rel_sv[relator_props]: "single_valued (⟨nat_rel⟩uv_set_rel)"
unfolding uv_set_rel_def by auto
lemma uv_autoref[autoref_rules,param]:
"(uv_lookup,(∈)) ∈ nat_rel → ⟨nat_rel⟩uv_set_rel → bool_rel"
"(uv_empty,{}) ∈ ⟨nat_rel⟩uv_set_rel"
"(uv_set_bit,insert) ∈ nat_rel → ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel"
"(uv_reset_bit,op_set_delete) ∈ nat_rel → ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel"
"(uv_union,(∪)) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel"
"(uv_inter,(∩)) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel"
"(uv_diff,(-)) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel"
"(uv_zeroes,op_set_isEmpty) ∈ ⟨nat_rel⟩uv_set_rel → bool_rel"
"(uv_equal,(=)) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → bool_rel"
"(uv_subseteq,(⊆)) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → bool_rel"
"(uv_subset,(⊂)) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → bool_rel"
"(uv_disjoint,op_set_disjoint) ∈ ⟨nat_rel⟩uv_set_rel → ⟨nat_rel⟩uv_set_rel → bool_rel"
by (auto
simp: uv_set_rel_def br_def
simp: uv_memb_correct uv_empty_correct uv_insert_correct uv_delete_correct
simp: uv_union_correct uv_inter_correct uv_diff_correct uv_isEmpty_correct
simp: uv_equal_correct uv_subseteq_correct uv_subset_correct uv_disjoint_correct)
export_code
uv_lookup
uv_empty
uv_single_bit
uv_set_bit
uv_reset_bit
uv_union
uv_inter
uv_diff
uv_zeroes
uv_equal
uv_subseteq
uv_subset
uv_disjoint
checking SML Scala Haskell? OCaml?
end
Theory Gen_Hash
theory Gen_Hash
imports "../Intf/Intf_Hash"
begin
definition "prod_bhc bhc1 bhc2 ≡ λn (a,b). (bhc1 n a * 33 + bhc2 n b) mod n"
lemma prod_bhc_ga[autoref_ga_rules]:
"⟦ GEN_ALGO_tag (is_bounded_hashcode R eq1 bhc1);
GEN_ALGO_tag (is_bounded_hashcode S eq2 bhc2)⟧
⟹ is_bounded_hashcode (R×⇩rS) (prod_eq eq1 eq2) (prod_bhc bhc1 bhc2)"
unfolding is_bounded_hashcode_def prod_bhc_def prod_eq_def[abs_def]
apply safe
apply (auto dest: fun_relD simp: Domain_unfold; metis)+
done
lemma prod_dhs_ga[autoref_ga_rules]:
"⟦ GEN_ALGO_tag (is_valid_def_hm_size TYPE('a) n1);
GEN_ALGO_tag (is_valid_def_hm_size TYPE('b) n2) ⟧
⟹ is_valid_def_hm_size TYPE('a*'b) (n1+n2)"
unfolding is_valid_def_hm_size_def by auto
end
Theory ICF_Chapter
theory ICF_Chapter
imports Main
begin
text_raw‹\isachapter{The Original Isabelle Collection Framework}›
text ‹
This chapter contains the original Isabelle Collection Framework.
It contains a vast amount of verified collection data structures, that are
included either directly or by parameterization via locales.
Generic algorithms need to be instantiated manually, and nesting of
collections (e.g.\ sets of sets) is not supported.
›
end
Theory ICF_Spec_Chapter
theory ICF_Spec_Chapter imports Main begin
text_raw ‹\isasection{Specifications} \label{ch:specs}›
end
Theory SetSpec
section ‹\isaheader{Specification of Sets}›
theory SetSpec
imports ICF_Spec_Base
begin
text_raw‹\label{thy:SetSpec}›
text ‹
This theory specifies set operations by means of a mapping to
HOL's standard sets.
›
notation insert ("set'_ins")
type_synonym ('x,'s) set_α = "'s ⇒ 'x set"
type_synonym ('x,'s) set_invar = "'s ⇒ bool"
locale set =
fixes α :: "'s ⇒ 'x set"
fixes invar :: "'s ⇒ bool"
locale set_no_invar = set +
assumes invar[simp, intro!]: "⋀s. invar s"
subsection "Basic Set Functions"
subsubsection "Empty set"
locale set_empty = set +
constrains α :: "'s ⇒ 'x set"
fixes empty :: "unit ⇒ 's"
assumes empty_correct:
"α (empty ()) = {}"
"invar (empty ())"
subsubsection "Membership Query"
locale set_memb = set +
constrains α :: "'s ⇒ 'x set"
fixes memb :: "'x ⇒ 's ⇒ bool"
assumes memb_correct:
"invar s ⟹ memb x s ⟷ x ∈ α s"
subsubsection "Insertion of Element"
locale set_ins = set +
constrains α :: "'s ⇒ 'x set"
fixes ins :: "'x ⇒ 's ⇒ 's"
assumes ins_correct:
"invar s ⟹ α (ins x s) = set_ins x (α s)"
"invar s ⟹ invar (ins x s)"
subsubsection "Disjoint Insert"
locale set_ins_dj = set +
constrains α :: "'s ⇒ 'x set"
fixes ins_dj :: "'x ⇒ 's ⇒ 's"
assumes ins_dj_correct:
"⟦invar s; x∉α s⟧ ⟹ α (ins_dj x s) = set_ins x (α s)"
"⟦invar s; x∉α s⟧ ⟹ invar (ins_dj x s)"
subsubsection "Deletion of Single Element"
locale set_delete = set +
constrains α :: "'s ⇒ 'x set"
fixes delete :: "'x ⇒ 's ⇒ 's"
assumes delete_correct:
"invar s ⟹ α (delete x s) = α s - {x}"
"invar s ⟹ invar (delete x s)"
subsubsection "Emptiness Check"
locale set_isEmpty = set +
constrains α :: "'s ⇒ 'x set"
fixes isEmpty :: "'s ⇒ bool"
assumes isEmpty_correct:
"invar s ⟹ isEmpty s ⟷ α s = {}"
subsubsection "Bounded Quantifiers"
locale set_ball = set +
constrains α :: "'s ⇒ 'x set"
fixes ball :: "'s ⇒ ('x ⇒ bool) ⇒ bool"
assumes ball_correct: "invar S ⟹ ball S P ⟷ (∀x∈α S. P x)"
locale set_bex = set +
constrains α :: "'s ⇒ 'x set"
fixes bex :: "'s ⇒ ('x ⇒ bool) ⇒ bool"
assumes bex_correct: "invar S ⟹ bex S P ⟷ (∃x∈α S. P x)"
subsubsection "Finite Set"
locale finite_set = set +
assumes finite[simp, intro!]: "invar s ⟹ finite (α s)"
subsubsection "Size"
locale set_size = finite_set +
constrains α :: "'s ⇒ 'x set"
fixes size :: "'s ⇒ nat"
assumes size_correct:
"invar s ⟹ size s = card (α s)"
locale set_size_abort = finite_set +
constrains α :: "'s ⇒ 'x set"
fixes size_abort :: "nat ⇒ 's ⇒ nat"
assumes size_abort_correct:
"invar s ⟹ size_abort m s = min m (card (α s))"
subsubsection "Singleton sets"
locale set_sng = set +
constrains α :: "'s ⇒ 'x set"
fixes sng :: "'x ⇒ 's"
assumes sng_correct:
"α (sng x) = {x}"
"invar (sng x)"
locale set_isSng = set +
constrains α :: "'s ⇒ 'x set"
fixes isSng :: "'s ⇒ bool"
assumes isSng_correct:
"invar s ⟹ isSng s ⟷ (∃e. α s = {e})"
begin
lemma isSng_correct_exists1 :
"invar s ⟹ (isSng s ⟷ (∃!e. (e ∈ α s)))"
by (auto simp add: isSng_correct)
lemma isSng_correct_card :
"invar s ⟹ (isSng s ⟷ (card (α s) = 1))"
by (auto simp add: isSng_correct card_Suc_eq)
end
subsection "Iterators"
text ‹
An iterator applies a
function to a state and all the elements of the set.
The function is applied in any order. Proofs over the iteration are
done by establishing invariants over the iteration.
Iterators may have a break-condition, that interrupts the iteration before
the last element has been visited.
›
type_synonym ('x,'s) set_list_it
= "'s ⇒ ('x,'x list) set_iterator"
locale poly_set_iteratei_defs =
fixes list_it :: "'s ⇒ ('x,'x list) set_iterator"
begin
definition iteratei :: "'s ⇒ ('x,'σ) set_iterator"
where "iteratei S ≡ it_to_it (list_it S)"
abbreviation "iterate s ≡ iteratei s (λ_. True)"
end
locale poly_set_iteratei =
finite_set + poly_set_iteratei_defs list_it
for list_it :: "'s ⇒ ('x,'x list) set_iterator" +
constrains α :: "'s ⇒ 'x set"
assumes list_it_correct: "invar s ⟹ set_iterator (list_it s) (α s)"
begin
lemma iteratei_correct: "invar S ⟹ set_iterator (iteratei S) (α S)"
unfolding iteratei_def
apply (rule it_to_it_correct)
by (rule list_it_correct)
lemma pi_iteratei[icf_proper_iteratorI]:
"proper_it (iteratei S) (iteratei S)"
unfolding iteratei_def
by (intro icf_proper_iteratorI)
lemma iteratei_rule_P:
"⟦
invar S;
I (α S) σ0;
!!x it σ. ⟦ c σ; x ∈ it; it ⊆ α S; I it σ ⟧ ⟹ I (it - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ;
!!σ it. ⟦ it ⊆ α S; it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ
⟧ ⟹ P (iteratei S c f σ0)"
apply (rule set_iterator_rule_P [OF iteratei_correct, of S I σ0 c f P])
apply simp_all
done
lemma iteratei_rule_insert_P:
"⟦
invar S;
I {} σ0;
!!x it σ. ⟦ c σ; x ∈ α S - it; it ⊆ α S; I it σ ⟧ ⟹ I (insert x it) (f x σ);
!!σ. I (α S) σ ⟹ P σ;
!!σ it. ⟦ it ⊆ α S; it ≠ α S; ¬ c σ; I it σ ⟧ ⟹ P σ
⟧ ⟹ P (iteratei S c f σ0)"
apply (rule
set_iterator_rule_insert_P[OF iteratei_correct, of S I σ0 c f P])
apply simp_all
done
text ‹Versions without break condition.›
lemma iterate_rule_P:
"⟦
invar S;
I (α S) σ0;
!!x it σ. ⟦ x ∈ it; it ⊆ α S; I it σ ⟧ ⟹ I (it - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (iteratei S (λ_. True) f σ0)"
apply (rule set_iterator_no_cond_rule_P [OF iteratei_correct, of S I σ0 f P])
apply simp_all
done
lemma iterate_rule_insert_P:
"⟦
invar S;
I {} σ0;
!!x it σ. ⟦ x ∈ α S - it; it ⊆ α S; I it σ ⟧ ⟹ I (insert x it) (f x σ);
!!σ. I (α S) σ ⟹ P σ
⟧ ⟹ P (iteratei S (λ_. True) f σ0)"
apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_correct,
of S I σ0 f P])
apply simp_all
done
end
subsection "More Set Operations"
subsubsection "Copy"
locale set_copy = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes copy :: "'s1 ⇒ 's2"
assumes copy_correct:
"invar1 s1 ⟹ α2 (copy s1) = α1 s1"
"invar1 s1 ⟹ invar2 (copy s1)"
subsubsection "Union"
locale set_union = s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
and α3 :: "'s3 ⇒ 'a set" and invar3
+
fixes union :: "'s1 ⇒ 's2 ⇒ 's3"
assumes union_correct:
"invar1 s1 ⟹ invar2 s2 ⟹ α3 (union s1 s2) = α1 s1 ∪ α2 s2"
"invar1 s1 ⟹ invar2 s2 ⟹ invar3 (union s1 s2)"
locale set_union_dj =
s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
and α3 :: "'s3 ⇒ 'a set" and invar3
+
fixes union_dj :: "'s1 ⇒ 's2 ⇒ 's3"
assumes union_dj_correct:
"⟦invar1 s1; invar2 s2; α1 s1 ∩ α2 s2 = {}⟧ ⟹ α3 (union_dj s1 s2) = α1 s1 ∪ α2 s2"
"⟦invar1 s1; invar2 s2; α1 s1 ∩ α2 s2 = {}⟧ ⟹ invar3 (union_dj s1 s2)"
locale set_union_list = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes union_list :: "'s1 list ⇒ 's2"
assumes union_list_correct:
"∀s1∈set l. invar1 s1 ⟹ α2 (union_list l) = ⋃{α1 s1 |s1. s1 ∈ set l}"
"∀s1∈set l. invar1 s1 ⟹ invar2 (union_list l)"
subsubsection "Difference"
locale set_diff = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes diff :: "'s1 ⇒ 's2 ⇒ 's1"
assumes diff_correct:
"invar1 s1 ⟹ invar2 s2 ⟹ α1 (diff s1 s2) = α1 s1 - α2 s2"
"invar1 s1 ⟹ invar2 s2 ⟹ invar1 (diff s1 s2)"
subsubsection "Intersection"
locale set_inter = s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
and α3 :: "'s3 ⇒ 'a set" and invar3
+
fixes inter :: "'s1 ⇒ 's2 ⇒ 's3"
assumes inter_correct:
"invar1 s1 ⟹ invar2 s2 ⟹ α3 (inter s1 s2) = α1 s1 ∩ α2 s2"
"invar1 s1 ⟹ invar2 s2 ⟹ invar3 (inter s1 s2)"
subsubsection "Subset"
locale set_subset = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes subset :: "'s1 ⇒ 's2 ⇒ bool"
assumes subset_correct:
"invar1 s1 ⟹ invar2 s2 ⟹ subset s1 s2 ⟷ α1 s1 ⊆ α2 s2"
subsubsection "Equal"
locale set_equal = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes equal :: "'s1 ⇒ 's2 ⇒ bool"
assumes equal_correct:
"invar1 s1 ⟹ invar2 s2 ⟹ equal s1 s2 ⟷ α1 s1 = α2 s2"
subsubsection "Image and Filter"
locale set_image_filter = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'b set" and invar2
+
fixes image_filter :: "('a ⇒ 'b option) ⇒ 's1 ⇒ 's2"
assumes image_filter_correct_aux:
"invar1 s ⟹ α2 (image_filter f s) = { b . ∃a∈α1 s. f a = Some b }"
"invar1 s ⟹ invar2 (image_filter f s)"
begin
lemma image_filter_correct_aux2:
"invar1 s ⟹
α2 (image_filter (λx. if P x then (Some (f x)) else None) s)
= f ` {x∈α1 s. P x}"
by (auto simp add: image_filter_correct_aux)
lemmas image_filter_correct =
image_filter_correct_aux2 image_filter_correct_aux
end
locale set_inj_image_filter = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'b set" and invar2
+
fixes inj_image_filter :: "('a ⇒ 'b option) ⇒ 's1 ⇒ 's2"
assumes inj_image_filter_correct:
"⟦invar1 s; inj_on f (α1 s ∩ dom f)⟧ ⟹ α2 (inj_image_filter f s) = { b . ∃a∈α1 s. f a = Some b }"
"⟦invar1 s; inj_on f (α1 s ∩ dom f)⟧ ⟹ invar2 (inj_image_filter f s)"
subsubsection "Image"
locale set_image = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'b set" and invar2
+
fixes image :: "('a ⇒ 'b) ⇒ 's1 ⇒ 's2"
assumes image_correct:
"invar1 s ⟹ α2 (image f s) = f`α1 s"
"invar1 s ⟹ invar2 (image f s)"
locale set_inj_image = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'b set" and invar2
+
fixes inj_image :: "('a ⇒ 'b) ⇒ 's1 ⇒ 's2"
assumes inj_image_correct:
"⟦invar1 s; inj_on f (α1 s)⟧ ⟹ α2 (inj_image f s) = f`α1 s"
"⟦invar1 s; inj_on f (α1 s)⟧ ⟹ invar2 (inj_image f s)"
subsubsection "Filter"
locale set_filter = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes filter :: "('a ⇒ bool) ⇒ 's1 ⇒ 's2"
assumes filter_correct:
"invar1 s ⟹ α2 (filter P s) = {e. e ∈ α1 s ∧ P e}"
"invar1 s ⟹ invar2 (filter P s)"
subsubsection "Union of Set of Sets"
locale set_Union_image =
s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'b set" and invar2
and α3 :: "'s3 ⇒ 'b set" and invar3
+
fixes Union_image :: "('a ⇒ 's2) ⇒ 's1 ⇒ 's3"
assumes Union_image_correct:
"⟦ invar1 s; !!x. x∈α1 s ⟹ invar2 (f x) ⟧ ⟹
α3 (Union_image f s) = ⋃(α2`f`α1 s)"
"⟦ invar1 s; !!x. x∈α1 s ⟹ invar2 (f x) ⟧ ⟹ invar3 (Union_image f s)"
subsubsection "Disjointness Check"
locale set_disjoint = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes disjoint :: "'s1 ⇒ 's2 ⇒ bool"
assumes disjoint_correct:
"invar1 s1 ⟹ invar2 s2 ⟹ disjoint s1 s2 ⟷ α1 s1 ∩ α2 s2 = {}"
subsubsection "Disjointness Check With Witness"
locale set_disjoint_witness = s1: set α1 invar1 + s2: set α2 invar2
for α1 :: "'s1 ⇒ 'a set" and invar1
and α2 :: "'s2 ⇒ 'a set" and invar2
+
fixes disjoint_witness :: "'s1 ⇒ 's2 ⇒ 'a option"
assumes disjoint_witness_correct:
"⟦invar1 s1; invar2 s2⟧
⟹ disjoint_witness s1 s2 = None ⟹ α1 s1 ∩ α2 s2 = {}"
"⟦invar1 s1; invar2 s2; disjoint_witness s1 s2 = Some a⟧
⟹ a∈α1 s1 ∩ α2 s2"
begin
lemma disjoint_witness_None: "⟦invar1 s1; invar2 s2⟧
⟹ disjoint_witness s1 s2 = None ⟷ α1 s1 ∩ α2 s2 = {}"
by (case_tac "disjoint_witness s1 s2")
(auto dest: disjoint_witness_correct)
lemma disjoint_witnessI: "⟦
invar1 s1;
invar2 s2;
α1 s1 ∩ α2 s2 ≠ {};
!!a. ⟦disjoint_witness s1 s2 = Some a⟧ ⟹ P
⟧ ⟹ P"
by (case_tac "disjoint_witness s1 s2")
(auto dest: disjoint_witness_correct)
end
subsubsection "Selection of Element"
locale set_sel = set +
constrains α :: "'s ⇒ 'x set"
fixes sel :: "'s ⇒ ('x ⇒ 'r option) ⇒ 'r option"
assumes selE:
"⟦ invar s; x∈α s; f x = Some r;
!!x r. ⟦sel s f = Some r; x∈α s; f x = Some r ⟧ ⟹ Q
⟧ ⟹ Q"
assumes selI: "⟦invar s; ∀x∈α s. f x = None ⟧ ⟹ sel s f = None"
begin
lemma sel_someD:
"⟦ invar s; sel s f = Some r; !!x. ⟦x∈α s; f x = Some r⟧ ⟹ P ⟧ ⟹ P"
apply (cases "∃x∈α s. ∃r. f x = Some r")
apply (safe)
apply (erule_tac f=f and x=x in selE)
apply auto
apply (drule (1) selI)
apply simp
done
lemma sel_noneD:
"⟦ invar s; sel s f = None; x∈α s ⟧ ⟹ f x = None"
apply (cases "∃x∈α s. ∃r. f x = Some r")
apply (safe)
apply (erule_tac f=f and x=xa in selE)
apply auto
done
end
locale set_sel' = set +
constrains α :: "'s ⇒ 'x set"
fixes sel' :: "'s ⇒ ('x ⇒ bool) ⇒ 'x option"
assumes sel'E:
"⟦ invar s; x∈α s; P x;
!!x. ⟦sel' s P = Some x; x∈α s; P x ⟧ ⟹ Q
⟧ ⟹ Q"
assumes sel'I: "⟦invar s; ∀x∈α s. ¬ P x ⟧ ⟹ sel' s P = None"
begin
lemma sel'_someD:
"⟦ invar s; sel' s P = Some x ⟧ ⟹ x∈α s ∧ P x"
apply (cases "∃x∈α s. P x")
apply (safe)
apply (erule_tac P=P and x=xa in sel'E)
apply auto
apply (erule_tac P=P and x=xa in sel'E)
apply auto
apply (drule (1) sel'I)
apply simp
apply (drule (1) sel'I)
apply simp
done
lemma sel'_noneD:
"⟦ invar s; sel' s P = None; x∈α s ⟧ ⟹ ¬P x"
apply (cases "∃x∈α s. P x")
apply (safe)
apply (erule_tac P=P and x=xa in sel'E)
apply auto
done
end
subsubsection "Conversion of Set to List"
locale set_to_list = set +
constrains α :: "'s ⇒ 'x set"
fixes to_list :: "'s ⇒ 'x list"
assumes to_list_correct:
"invar s ⟹ set (to_list s) = α s"
"invar s ⟹ distinct (to_list s)"
subsubsection "Conversion of List to Set"
locale list_to_set = set +
constrains α :: "'s ⇒ 'x set"
fixes to_set :: "'x list ⇒ 's"
assumes to_set_correct:
"α (to_set l) = set l"
"invar (to_set l)"
subsection "Ordered Sets"
locale ordered_set = set α invar
for α :: "'s ⇒ ('u::linorder) set" and invar
locale ordered_finite_set = finite_set α invar + ordered_set α invar
for α :: "'s ⇒ ('u::linorder) set" and invar
subsubsection "Ordered Iteration"
locale poly_set_iterateoi_defs =
fixes olist_it :: "'s ⇒ ('x,'x list) set_iterator"
begin
definition iterateoi :: "'s ⇒ ('x,'σ) set_iterator"
where "iterateoi S ≡ it_to_it (olist_it S)"
abbreviation "iterateo s ≡ iterateoi s (λ_. True)"
end
locale poly_set_iterateoi =
finite_set α invar + poly_set_iterateoi_defs list_ordered_it
for α :: "'s ⇒ 'x::linorder set"
and invar
and list_ordered_it :: "'s ⇒ ('x,'x list) set_iterator" +
assumes list_ordered_it_correct: "invar x
⟹ set_iterator_linord (list_ordered_it x) (α x)"
begin
lemma iterateoi_correct:
"invar S ⟹ set_iterator_linord (iterateoi S) (α S)"
unfolding iterateoi_def
apply (rule it_to_it_linord_correct)
by (rule list_ordered_it_correct)
lemma pi_iterateoi[icf_proper_iteratorI]:
"proper_it (iterateoi S) (iterateoi S)"
unfolding iterateoi_def
by (intro icf_proper_iteratorI)
lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar s"
assumes I0: "I (α s) σ0"
assumes IP: "!!k it σ. ⟦
c σ;
k ∈ it;
∀j∈it. k≤j;
∀j∈α s - it. j≤k;
it ⊆ α s;
I it σ
⟧ ⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ α s;
it ≠ {};
¬ c σ;
I it σ;
∀k∈it. ∀j∈α s - it. j≤k
⟧ ⟹ P σ"
shows "P (iterateoi s c f σ0)"
using set_iterator_linord_rule_P [OF iterateoi_correct,
OF MINV, of I σ0 c f P, OF I0 _ IF] IP II
by simp
lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar s"
assumes I0: "I ((α s)) σ0"
assumes IP: "!!k it σ. ⟦ k ∈ it; ∀j∈it. k≤j;
∀j∈(α s) - it. j≤k; it ⊆ (α s); I it σ ⟧
⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (iterateo s f σ0)"
apply (rule iterateoi_rule_P [where I = I])
apply (simp_all add: assms)
done
end
locale poly_set_rev_iterateoi_defs =
fixes list_rev_it :: "'s ⇒ ('x::linorder,'x list) set_iterator"
begin
definition rev_iterateoi :: "'s ⇒ ('x,'σ) set_iterator"
where "rev_iterateoi S ≡ it_to_it (list_rev_it S)"
abbreviation "rev_iterateo m ≡ rev_iterateoi m (λ_. True)"
abbreviation "reverse_iterateoi ≡ rev_iterateoi"
abbreviation "reverse_iterateo ≡ rev_iterateo"
end
locale poly_set_rev_iterateoi =
finite_set α invar + poly_set_rev_iterateoi_defs list_rev_it
for α :: "'s ⇒ 'x::linorder set"
and invar
and list_rev_it :: "'s ⇒ ('x,'x list) set_iterator" +
assumes list_rev_it_correct:
"invar s ⟹ set_iterator_rev_linord (list_rev_it s) (α s)"
begin
lemma rev_iterateoi_correct:
"invar S ⟹ set_iterator_rev_linord (rev_iterateoi S) (α S)"
unfolding rev_iterateoi_def
apply (rule it_to_it_rev_linord_correct)
by (rule list_rev_it_correct)
lemma pi_rev_iterateoi[icf_proper_iteratorI]:
"proper_it (rev_iterateoi S) (rev_iterateoi S)"
unfolding rev_iterateoi_def
by (intro icf_proper_iteratorI)
lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar s"
assumes I0: "I ((α s)) σ0"
assumes IP: "!!k it σ. ⟦
c σ;
k ∈ it;
∀j∈it. k≥j;
∀j∈(α s) - it. j≥k;
it ⊆ (α s);
I it σ
⟧ ⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ (α s);
it ≠ {};
¬ c σ;
I it σ;
∀k∈it. ∀j∈(α s) - it. j≥k
⟧ ⟹ P σ"
shows "P (rev_iterateoi s c f σ0)"
using set_iterator_rev_linord_rule_P [OF rev_iterateoi_correct,
OF MINV, of I σ0 c f P, OF I0 _ IF] IP II
by simp
lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar s"
assumes I0: "I ((α s)) σ0"
assumes IP: "!!k it σ. ⟦
k ∈ it;
∀j∈it. k≥j;
∀j∈ (α s) - it. j≥k;
it ⊆ (α s);
I it σ
⟧ ⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (rev_iterateo s f σ0)"
apply (rule rev_iterateoi_rule_P [where I = I])
apply (simp_all add: assms)
done
end
subsubsection "Minimal and Maximal Element"
locale set_min = ordered_set +
constrains α :: "'s ⇒ 'u::linorder set"
fixes min :: "'s ⇒ ('u ⇒ bool) ⇒ 'u option"
assumes min_correct:
"⟦ invar s; x∈α s; P x ⟧ ⟹ min s P ∈ Some ` {x∈α s. P x}"
"⟦ invar s; x∈α s; P x ⟧ ⟹ (the (min s P)) ≤ x"
"⟦ invar s; {x∈α s. P x} = {} ⟧ ⟹ min s P = None"
begin
lemma minE:
assumes A: "invar s" "x∈α s" "P x"
obtains x' where
"min s P = Some x'" "x'∈α s" "P x'" "∀x∈α s. P x ⟶ x' ≤ x"
proof -
from min_correct(1)[of s x P, OF A] have
MIS: "min s P ∈ Some ` {x ∈ α s. P x}" .
then obtain x' where KV: "min s P = Some x'" "x'∈α s" "P x'"
by auto
show thesis
apply (rule that[OF KV])
apply (clarify)
apply (drule (1) min_correct(2)[OF ‹invar s›])
apply (simp add: KV(1))
done
qed
lemmas minI = min_correct(3)
lemma min_Some:
"⟦ invar s; min s P = Some x ⟧ ⟹ x∈α s"
"⟦ invar s; min s P = Some x ⟧ ⟹ P x"
"⟦ invar s; min s P = Some x; x'∈α s; P x'⟧ ⟹ x≤x'"
apply -
apply (cases "{x ∈ α s. P x} = {}")
apply (drule (1) min_correct(3))
apply simp
apply simp
apply (erule exE)
apply clarify
apply (drule (2) min_correct(1)[of s _ P])
apply auto [1]
apply (cases "{x ∈ α s. P x} = {}")
apply (drule (1) min_correct(3))
apply simp
apply simp
apply (erule exE)
apply clarify
apply (drule (2) min_correct(1)[of s _ P])
apply auto [1]
apply (drule (2) min_correct(2)[where P=P])
apply auto
done
lemma min_None:
"⟦ invar s; min s P = None ⟧ ⟹ {x∈α s. P x} = {}"
apply (cases "{x∈α s. P x} = {}")
apply simp
apply simp
apply (erule exE)
apply clarify
apply (drule (2) min_correct(1)[where P=P])
apply auto
done
end
locale set_max = ordered_set +
constrains α :: "'s ⇒ 'u::linorder set"
fixes max :: "'s ⇒ ('u ⇒ bool) ⇒ 'u option"
assumes max_correct:
"⟦ invar s; x∈α s; P x ⟧ ⟹ max s P ∈ Some ` {x∈α s. P x}"
"⟦ invar s; x∈α s; P x ⟧ ⟹ the (max s P) ≥ x"
"⟦ invar s; {x∈α s. P x} = {} ⟧ ⟹ max s P = None"
begin
lemma maxE:
assumes A: "invar s" "x∈α s" "P x"
obtains x' where
"max s P = Some x'" "x'∈α s" "P x'" "∀x∈α s. P x ⟶ x' ≥ x"
proof -
from max_correct(1)[where P=P, OF A] have
MIS: "max s P ∈ Some ` {x∈α s. P x}" .
then obtain x' where KV: "max s P = Some x'" "x'∈ α s" "P x'"
by auto
show thesis
apply (rule that[OF KV])
apply (clarify)
apply (drule (1) max_correct(2)[OF ‹invar s›])
apply (simp add: KV(1))
done
qed
lemmas maxI = max_correct(3)
lemma max_Some:
"⟦ invar s; max s P = Some x ⟧ ⟹ x∈α s"
"⟦ invar s; max s P = Some x ⟧ ⟹ P x"
"⟦ invar s; max s P = Some x; x'∈α s; P x'⟧ ⟹ x≥x'"
apply -
apply (cases "{x∈α s. P x} = {}")
apply (drule (1) max_correct(3))
apply simp
apply simp
apply (erule exE)
apply clarify
apply (drule (2) max_correct(1)[of s _ P])
apply auto [1]
apply (cases "{x∈α s. P x} = {}")
apply (drule (1) max_correct(3))
apply simp
apply simp
apply (erule exE)
apply clarify
apply (drule (2) max_correct(1)[of s _ P])
apply auto [1]
apply (drule (1) max_correct(2)[where P=P])
apply auto
done
lemma max_None:
"⟦ invar s; max s P = None ⟧ ⟹ {x∈α s. P x} = {}"
apply (cases "{x∈α s. P x} = {}")
apply simp
apply simp
apply (erule exE)
apply clarify
apply (drule (1) max_correct(1)[where P=P])
apply auto
done
end
subsection "Conversion to List"
locale set_to_sorted_list = ordered_set +
constrains α :: "'s ⇒ 'x::linorder set"
fixes to_sorted_list :: "'s ⇒ 'x list"
assumes to_sorted_list_correct:
"invar s ⟹ set (to_sorted_list s) = α s"
"invar s ⟹ distinct (to_sorted_list s)"
"invar s ⟹ sorted (to_sorted_list s)"
locale set_to_rev_list = ordered_set +
constrains α :: "'s ⇒ 'x::linorder set"
fixes to_rev_list :: "'s ⇒ 'x list"
assumes to_rev_list_correct:
"invar s ⟹ set (to_rev_list s) = α s"
"invar s ⟹ distinct (to_rev_list s)"
"invar s ⟹ sorted (rev (to_rev_list s))"
subsection "Record Based Interface"
record ('x,'s) set_ops =
set_op_α :: "'s ⇒ 'x set"
set_op_invar :: "'s ⇒ bool"
set_op_empty :: "unit ⇒ 's"
set_op_memb :: "'x ⇒ 's ⇒ bool"
set_op_ins :: "'x ⇒ 's ⇒ 's"
set_op_ins_dj :: "'x ⇒ 's ⇒ 's"
set_op_delete :: "'x ⇒ 's ⇒ 's"
set_op_list_it :: "('x,'s) set_list_it"
set_op_sng :: "'x ⇒ 's"
set_op_isEmpty :: "'s ⇒ bool"
set_op_isSng :: "'s ⇒ bool"
set_op_ball :: "'s ⇒ ('x ⇒ bool) ⇒ bool"
set_op_bex :: "'s ⇒ ('x ⇒ bool) ⇒ bool"
set_op_size :: "'s ⇒ nat"
set_op_size_abort :: "nat ⇒ 's ⇒ nat"
set_op_union :: "'s ⇒ 's ⇒ 's"
set_op_union_dj :: "'s ⇒ 's ⇒ 's"
set_op_diff :: "'s ⇒ 's ⇒ 's"
set_op_filter :: "('x ⇒ bool) ⇒ 's ⇒ 's"
set_op_inter :: "'s ⇒ 's ⇒ 's"
set_op_subset :: "'s ⇒ 's ⇒ bool"
set_op_equal :: "'s ⇒ 's ⇒ bool"
set_op_disjoint :: "'s ⇒ 's ⇒ bool"
set_op_disjoint_witness :: "'s ⇒ 's ⇒ 'x option"
set_op_sel :: "'s ⇒ ('x ⇒ bool) ⇒ 'x option"
set_op_to_list :: "'s ⇒ 'x list"
set_op_from_list :: "'x list ⇒ 's"
locale StdSetDefs =
poly_set_iteratei_defs "set_op_list_it ops"
for ops :: "('x,'s,'more) set_ops_scheme"
begin
abbreviation α where "α == set_op_α ops"
abbreviation invar where "invar == set_op_invar ops"
abbreviation empty where "empty == set_op_empty ops"
abbreviation memb where "memb == set_op_memb ops"
abbreviation ins where "ins == set_op_ins ops"
abbreviation ins_dj where "ins_dj == set_op_ins_dj ops"
abbreviation delete where "delete == set_op_delete ops"
abbreviation list_it where "list_it ≡ set_op_list_it ops"
abbreviation sng where "sng == set_op_sng ops"
abbreviation isEmpty where "isEmpty == set_op_isEmpty ops"
abbreviation isSng where "isSng == set_op_isSng ops"
abbreviation ball where "ball == set_op_ball ops"
abbreviation bex where "bex == set_op_bex ops"
abbreviation size where "size == set_op_size ops"
abbreviation size_abort where "size_abort == set_op_size_abort ops"
abbreviation union where "union == set_op_union ops"
abbreviation union_dj where "union_dj == set_op_union_dj ops"
abbreviation diff where "diff == set_op_diff ops"
abbreviation filter where "filter == set_op_filter ops"
abbreviation inter where "inter == set_op_inter ops"
abbreviation subset where "subset == set_op_subset ops"
abbreviation equal where "equal == set_op_equal ops"
abbreviation disjoint where "disjoint == set_op_disjoint ops"
abbreviation disjoint_witness
where "disjoint_witness == set_op_disjoint_witness ops"
abbreviation sel where "sel == set_op_sel ops"
abbreviation to_list where "to_list == set_op_to_list ops"
abbreviation from_list where "from_list == set_op_from_list ops"
end
locale StdSet = StdSetDefs ops +
set α invar +
set_empty α invar empty +
set_memb α invar memb +
set_ins α invar ins +
set_ins_dj α invar ins_dj +
set_delete α invar delete +
poly_set_iteratei α invar list_it +
set_sng α invar sng +
set_isEmpty α invar isEmpty +
set_isSng α invar isSng +
set_ball α invar ball +
set_bex α invar bex +
set_size α invar size +
set_size_abort α invar size_abort +
set_union α invar α invar α invar union +
set_union_dj α invar α invar α invar union_dj +
set_diff α invar α invar diff +
set_filter α invar α invar filter +
set_inter α invar α invar α invar inter +
set_subset α invar α invar subset +
set_equal α invar α invar equal +
set_disjoint α invar α invar disjoint +
set_disjoint_witness α invar α invar disjoint_witness +
set_sel' α invar sel +
set_to_list α invar to_list +
list_to_set α invar from_list
for ops :: "('x,'s,'more) set_ops_scheme"
begin
lemmas correct =
empty_correct
sng_correct
memb_correct
ins_correct
ins_dj_correct
delete_correct
isEmpty_correct
isSng_correct
ball_correct
bex_correct
size_correct
size_abort_correct
union_correct
union_dj_correct
diff_correct
filter_correct
inter_correct
subset_correct
equal_correct
disjoint_correct
disjoint_witness_correct
to_list_correct
to_set_correct
end
lemmas StdSet_intro = StdSet.intro[rem_dup_prems]
locale StdSet_no_invar = StdSet + set_no_invar α invar
record ('x,'s) oset_ops = "('x::linorder,'s) set_ops" +
set_op_ordered_list_it :: "'s ⇒ ('x,'x list) set_iterator"
set_op_rev_list_it :: "'s ⇒ ('x,'x list) set_iterator"
set_op_min :: "'s ⇒ ('x ⇒ bool) ⇒ 'x option"
set_op_max :: "'s ⇒ ('x ⇒ bool) ⇒ 'x option"
set_op_to_sorted_list :: "'s ⇒ 'x list"
set_op_to_rev_list :: "'s ⇒ 'x list"
locale StdOSetDefs = StdSetDefs ops
+ poly_set_iterateoi_defs "set_op_ordered_list_it ops"
+ poly_set_rev_iterateoi_defs "set_op_rev_list_it ops"
for ops :: "('x::linorder,'s,'more) oset_ops_scheme"
begin
abbreviation "ordered_list_it ≡ set_op_ordered_list_it ops"
abbreviation "rev_list_it ≡ set_op_rev_list_it ops"
abbreviation min where "min == set_op_min ops"
abbreviation max where "max == set_op_max ops"
abbreviation to_sorted_list where
"to_sorted_list ≡ set_op_to_sorted_list ops"
abbreviation to_rev_list where "to_rev_list ≡ set_op_to_rev_list ops"
end
locale StdOSet =
StdOSetDefs ops +
StdSet ops +
poly_set_iterateoi α invar ordered_list_it +
poly_set_rev_iterateoi α invar rev_list_it +
set_min α invar min +
set_max α invar max +
set_to_sorted_list α invar to_sorted_list +
set_to_rev_list α invar to_rev_list
for ops :: "('x::linorder,'s,'more) oset_ops_scheme"
begin
end
lemmas StdOSet_intro =
StdOSet.intro[OF StdSet_intro, rem_dup_prems]
no_notation insert ("set'_ins")
end
Theory ListSpec
section ‹\isaheader{Specification of Sequences}›
theory ListSpec
imports ICF_Spec_Base
begin
subsection "Definition"
locale list =
fixes α :: "'s ⇒ 'x list"
fixes invar :: "'s ⇒ bool"
locale list_no_invar = list +
assumes invar[simp, intro!]: "⋀l. invar l"
subsection "Functions"
locale list_empty = list +
constrains α :: "'s ⇒ 'x list"
fixes empty :: "unit ⇒ 's"
assumes empty_correct:
"α (empty ()) = []"
"invar (empty ())"
locale list_isEmpty = list +
constrains α :: "'s ⇒ 'x list"
fixes isEmpty :: "'s ⇒ bool"
assumes isEmpty_correct:
"invar s ⟹ isEmpty s ⟷ α s = []"
locale poly_list_iteratei = list +
constrains α :: "'s ⇒ 'x list"
begin
definition iteratei where
iteratei_correct[code_unfold]: "iteratei s ≡ foldli (α s)"
definition iterate where
iterate_correct[code_unfold]: "iterate s ≡ foldli (α s) (λ_. True)"
end
locale poly_list_rev_iteratei = list +
constrains α :: "'s ⇒ 'x list"
begin
definition rev_iteratei where
rev_iteratei_correct[code_unfold]: "rev_iteratei s ≡ foldri (α s)"
definition rev_iterate where
rev_iterate_correct[code_unfold]: "rev_iterate s ≡ foldri (α s) (λ_. True)"
end
locale list_size = list +
constrains α :: "'s ⇒ 'x list"
fixes size :: "'s ⇒ nat"
assumes size_correct:
"invar s ⟹ size s = length (α s)"
locale list_appendl = list +
constrains α :: "'s ⇒ 'x list"
fixes appendl :: "'x ⇒ 's ⇒ 's"
assumes appendl_correct:
"invar s ⟹ α (appendl x s) = x#α s"
"invar s ⟹ invar (appendl x s)"
begin
abbreviation (input) "push ≡ appendl"
lemmas push_correct = appendl_correct
end
locale list_removel = list +
constrains α :: "'s ⇒ 'x list"
fixes removel :: "'s ⇒ ('x × 's)"
assumes removel_correct:
"⟦invar s; α s ≠ []⟧ ⟹ fst (removel s) = hd (α s)"
"⟦invar s; α s ≠ []⟧ ⟹ α (snd (removel s)) = tl (α s)"
"⟦invar s; α s ≠ []⟧ ⟹ invar (snd (removel s))"
begin
lemma removelE:
assumes I: "invar s" "α s ≠ []"
obtains s' where "removel s = (hd (α s), s')" "invar s'" "α s' = tl (α s)"
proof -
from removel_correct(1,2,3)[OF I] have
C: "fst (removel s) = hd (α s)"
"α (snd (removel s)) = tl (α s)"
"invar (snd (removel s))" .
from that[of "snd (removel s)", OF _ C(3,2), folded C(1)] show thesis
by simp
qed
text ‹The following shortcut notations are not meant for generating efficient code,
but solely to simplify reasoning›
abbreviation (input) "pop ≡ removel"
lemmas pop_correct = removel_correct
abbreviation (input) "dequeue ≡ removel"
lemmas dequeue_correct = removel_correct
end
locale list_leftmost = list +
constrains α :: "'s ⇒ 'x list"
fixes leftmost :: "'s ⇒ 'x"
assumes leftmost_correct:
"⟦invar s; α s ≠ []⟧ ⟹ leftmost s = hd (α s)"
begin
abbreviation (input) top where "top ≡ leftmost"
lemmas top_correct = leftmost_correct
end
locale list_appendr = list +
constrains α :: "'s ⇒ 'x list"
fixes appendr :: "'x ⇒ 's ⇒ 's"
assumes appendr_correct:
"invar s ⟹ α (appendr x s) = α s @ [x]"
"invar s ⟹ invar (appendr x s)"
begin
abbreviation (input) "enqueue ≡ appendr"
lemmas enqueue_correct = appendr_correct
end
locale list_remover = list +
constrains α :: "'s ⇒ 'x list"
fixes remover :: "'s ⇒ 's × 'x"
assumes remover_correct:
"⟦invar s; α s ≠ []⟧ ⟹ α (fst (remover s)) = butlast (α s)"
"⟦invar s; α s ≠ []⟧ ⟹ snd (remover s) = last (α s)"
"⟦invar s; α s ≠ []⟧ ⟹ invar (fst (remover s))"
locale list_rightmost = list +
constrains α :: "'s ⇒ 'x list"
fixes rightmost :: "'s ⇒ 'x"
assumes rightmost_correct:
"⟦invar s; α s ≠ []⟧ ⟹ rightmost s = List.last (α s)"
begin
abbreviation (input) bot where "bot ≡ rightmost"
lemmas bot_correct = rightmost_correct
end
subsubsection "Indexing"
locale list_get = list +
constrains α :: "'s ⇒ 'x list"
fixes get :: "'s ⇒ nat ⇒ 'x"
assumes get_correct:
"⟦invar s; i<length (α s)⟧ ⟹ get s i = α s ! i"
locale list_set = list +
constrains α :: "'s ⇒ 'x list"
fixes set :: "'s ⇒ nat ⇒ 'x ⇒ 's"
assumes set_correct:
"⟦invar s; i<length (α s)⟧ ⟹ α (set s i x) = (α s) [i := x]"
"⟦invar s; i<length (α s)⟧ ⟹ invar (set s i x)"
record ('a,'s) list_ops =
list_op_α :: "'s ⇒ 'a list"
list_op_invar :: "'s ⇒ bool"
list_op_empty :: "unit ⇒ 's"
list_op_isEmpty :: "'s ⇒ bool"
list_op_size :: "'s ⇒ nat"
list_op_appendl :: "'a ⇒ 's ⇒ 's"
list_op_removel :: "'s ⇒ 'a × 's"
list_op_leftmost :: "'s ⇒ 'a"
list_op_appendr :: "'a ⇒ 's ⇒ 's"
list_op_remover :: "'s ⇒ 's × 'a"
list_op_rightmost :: "'s ⇒ 'a"
list_op_get :: "'s ⇒ nat ⇒ 'a"
list_op_set :: "'s ⇒ nat ⇒ 'a ⇒ 's"
locale StdListDefs =
poly_list_iteratei "list_op_α ops" "list_op_invar ops"
+ poly_list_rev_iteratei "list_op_α ops" "list_op_invar ops"
for ops :: "('a,'s,'more) list_ops_scheme"
begin
abbreviation α where "α ≡ list_op_α ops"
abbreviation invar where "invar ≡ list_op_invar ops"
abbreviation empty where "empty ≡ list_op_empty ops"
abbreviation isEmpty where "isEmpty ≡ list_op_isEmpty ops"
abbreviation size where "size ≡ list_op_size ops"
abbreviation appendl where "appendl ≡ list_op_appendl ops"
abbreviation removel where "removel ≡ list_op_removel ops"
abbreviation leftmost where "leftmost ≡ list_op_leftmost ops"
abbreviation appendr where "appendr ≡ list_op_appendr ops"
abbreviation remover where "remover ≡ list_op_remover ops"
abbreviation rightmost where "rightmost ≡ list_op_rightmost ops"
abbreviation get where "get ≡ list_op_get ops"
abbreviation set where "set ≡ list_op_set ops"
end
locale StdList = StdListDefs ops
+ list α invar
+ list_empty α invar empty
+ list_isEmpty α invar isEmpty
+ list_size α invar size
+ list_appendl α invar appendl
+ list_removel α invar removel
+ list_leftmost α invar leftmost
+ list_appendr α invar appendr
+ list_remover α invar remover
+ list_rightmost α invar rightmost
+ list_get α invar get
+ list_set α invar set
for ops :: "('a,'s,'more) list_ops_scheme"
begin
lemmas correct =
empty_correct
isEmpty_correct
size_correct
appendl_correct
removel_correct
leftmost_correct
appendr_correct
remover_correct
rightmost_correct
get_correct
set_correct
end
locale StdList_no_invar = StdList + list_no_invar α invar
end
Theory AnnotatedListSpec
section ‹\isaheader{Specification of Annotated Lists}›
theory AnnotatedListSpec
imports ICF_Spec_Base
begin
subsection "Introduction"
text ‹
We define lists with annotated elements. The annotations form a monoid.
We provide standard list operations and the split-operation, that
splits the list according to its annotations.
›
locale al =
fixes α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes invar :: "'s ⇒ bool"
locale al_no_invar = al +
assumes invar[simp, intro!]: "⋀l. invar l"
subsection "Basic Annotated List Operations"
subsubsection "Empty Annotated List"
locale al_empty = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes empty :: "unit ⇒ 's"
assumes empty_correct:
"invar (empty ())"
"α (empty ()) = Nil"
subsubsection "Emptiness Check"
locale al_isEmpty = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes isEmpty :: "'s ⇒ bool"
assumes isEmpty_correct:
"invar s ⟹ isEmpty s ⟷ α s = Nil"
subsubsection "Counting Elements"
locale al_count = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes count :: "'s ⇒ nat"
assumes count_correct:
"invar s ⟹ count s = length(α s)"
subsubsection "Appending an Element from the Left"
locale al_consl = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes consl :: "'e ⇒ 'a ⇒ 's ⇒ 's"
assumes consl_correct:
"invar s ⟹ invar (consl e a s)"
"invar s ⟹ (α (consl e a s)) = (e,a) # (α s)"
subsubsection "Appending an Element from the Right"
locale al_consr = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes consr :: "'s ⇒ 'e ⇒ 'a ⇒ 's"
assumes consr_correct:
"invar s ⟹ invar (consr s e a)"
"invar s ⟹ (α (consr s e a)) = (α s) @ [(e,a)]"
subsubsection "Take the First Element"
locale al_head = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes head :: "'s ⇒ ('e × 'a)"
assumes head_correct:
"⟦invar s; α s ≠ Nil⟧ ⟹ head s = hd (α s)"
subsubsection "Drop the First Element"
locale al_tail = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes tail :: "'s ⇒ 's"
assumes tail_correct:
"⟦invar s; α s ≠ Nil⟧ ⟹ α (tail s) = tl (α s)"
"⟦invar s; α s ≠ Nil⟧ ⟹ invar (tail s)"
subsubsection "Take the Last Element"
locale al_headR = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes headR :: "'s ⇒ ('e × 'a)"
assumes headR_correct:
"⟦invar s; α s ≠ Nil⟧ ⟹ headR s = last (α s)"
subsubsection "Drop the Last Element"
locale al_tailR = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes tailR :: "'s ⇒ 's"
assumes tailR_correct:
"⟦invar s; α s ≠ Nil⟧ ⟹ α (tailR s) = butlast (α s)"
"⟦invar s; α s ≠ Nil⟧ ⟹ invar (tailR s)"
subsubsection "Fold a Function over the Elements from the Left"
locale al_foldl = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes foldl :: "('z ⇒ 'e × 'a ⇒ 'z) ⇒ 'z ⇒ 's ⇒ 'z"
assumes foldl_correct:
"invar s ⟹ foldl f σ s = List.foldl f σ (α s)"
subsubsection "Fold a Function over the Elements from the Right"
locale al_foldr = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes foldr :: "('e × 'a ⇒ 'z ⇒ 'z) ⇒ 's ⇒ 'z ⇒ 'z"
assumes foldr_correct:
"invar s ⟹ foldr f s σ = List.foldr f (α s) σ"
locale poly_al_fold = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
begin
definition foldl where
foldl_correct[code_unfold]: "foldl f σ s = List.foldl f σ (α s)"
definition foldr where
foldr_correct[code_unfold]: "foldr f s σ = List.foldr f (α s) σ"
end
subsubsection "Concatenation of Two Annotated Lists"
locale al_app = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes app :: "'s ⇒ 's ⇒ 's"
assumes app_correct:
"⟦invar s;invar s'⟧ ⟹ α (app s s') = (α s) @ (α s')"
"⟦invar s;invar s'⟧ ⟹ invar (app s s')"
subsubsection "Readout the Summed up Annotations"
locale al_annot = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes annot :: "'s ⇒ 'a"
assumes annot_correct:
"invar s ⟹ (annot s) = (sum_list (map snd (α s)))"
subsubsection "Split by Monotone Predicate"
locale al_splits = al +
constrains α :: "'s ⇒ ('e × 'a::monoid_add) list"
fixes splits :: "('a ⇒ bool) ⇒ 'a ⇒ 's ⇒
('s × ('e × 'a) × 's)"
assumes splits_correct:
"⟦invar s;
∀a b. p a ⟶ p (a + b);
¬ p i;
p (i + sum_list (map snd (α s)));
(splits p i s) = (l, (e,a), r)⟧
⟹
(α s) = (α l) @ (e,a) # (α r) ∧
¬ p (i + sum_list (map snd (α l))) ∧
p (i + sum_list (map snd (α l)) + a) ∧
invar l ∧
invar r
"
begin
lemma splitsE:
assumes
invar: "invar s" and
mono: "∀a b. p a ⟶ p (a + b)" and
init_ff: "¬ p i" and
sum_tt: "p (i + sum_list (map snd (α s)))"
obtains l e a r where
"(splits p i s) = (l, (e,a), r)"
"(α s) = (α l) @ (e,a) # (α r)"
"¬ p (i + sum_list (map snd (α l)))"
"p (i + sum_list (map snd (α l)) + a)"
"invar l"
"invar r"
using assms
apply (cases "splits p i s")
apply (case_tac b)
apply (drule_tac i = i and p = p
and l = a and r = c and e = aa and a = ba in splits_correct)
apply (simp_all)
done
end
subsection "Record Based Interface"
record ('e,'a,'s) alist_ops =
alist_op_α ::"'s ⇒ ('e × 'a::monoid_add) list"
alist_op_invar :: "'s ⇒ bool"
alist_op_empty :: "unit ⇒ 's"
alist_op_isEmpty :: "'s ⇒ bool"
alist_op_count :: "'s ⇒ nat"
alist_op_consl :: "'e ⇒ 'a ⇒ 's ⇒ 's"
alist_op_consr :: "'s ⇒ 'e ⇒ 'a ⇒ 's"
alist_op_head :: "'s ⇒ ('e × 'a)"
alist_op_tail :: "'s ⇒ 's"
alist_op_headR :: "'s ⇒ ('e × 'a)"
alist_op_tailR :: "'s ⇒ 's"
alist_op_app :: "'s ⇒ 's ⇒ 's"
alist_op_annot :: "'s ⇒ 'a"
alist_op_splits :: "('a ⇒ bool) ⇒ 'a ⇒ 's ⇒ ('s × ('e × 'a) × 's)"
locale StdALDefs = poly_al_fold "alist_op_α ops" "alist_op_invar ops"
for ops :: "('e,'a::monoid_add,'s,'more) alist_ops_scheme"
begin
abbreviation α where "α == alist_op_α ops"
abbreviation invar where "invar == alist_op_invar ops "
abbreviation empty where "empty == alist_op_empty ops "
abbreviation isEmpty where "isEmpty == alist_op_isEmpty ops "
abbreviation count where "count == alist_op_count ops"
abbreviation consl where "consl == alist_op_consl ops "
abbreviation consr where "consr == alist_op_consr ops "
abbreviation head where "head == alist_op_head ops "
abbreviation tail where "tail == alist_op_tail ops "
abbreviation headR where "headR == alist_op_headR ops "
abbreviation tailR where "tailR == alist_op_tailR ops "
abbreviation app where "app == alist_op_app ops "
abbreviation annot where "annot == alist_op_annot ops "
abbreviation splits where "splits == alist_op_splits ops "
end
locale StdAL = StdALDefs ops +
al α invar +
al_empty α invar empty +
al_isEmpty α invar isEmpty +
al_count α invar count +
al_consl α invar consl +
al_consr α invar consr +
al_head α invar head +
al_tail α invar tail +
al_headR α invar headR +
al_tailR α invar tailR +
al_app α invar app +
al_annot α invar annot +
al_splits α invar splits
for ops
begin
lemmas correct =
empty_correct
isEmpty_correct
count_correct
consl_correct
consr_correct
head_correct
tail_correct
headR_correct
tailR_correct
app_correct
annot_correct
foldl_correct
foldr_correct
end
locale StdAL_no_invar = StdAL + al_no_invar α invar
end
Theory PrioSpec
section ‹\isaheader{Specification of Priority Queues}›
theory PrioSpec
imports ICF_Spec_Base "HOL-Library.Multiset"
begin
text ‹
We specify priority queues, that are abstracted to
multisets of pairs of elements and priorities.
›
locale prio =
fixes α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes invar :: "'p ⇒ bool"
locale prio_no_invar = prio +
assumes invar[simp, intro!]: "⋀s. invar s"
subsection "Basic Priority Queue Functions"
subsubsection "Empty Queue"
locale prio_empty = prio +
constrains α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes empty :: "unit ⇒ 'p"
assumes empty_correct:
"invar (empty ())"
"α (empty ()) = {#}"
subsubsection "Emptiness Predicate"
locale prio_isEmpty = prio +
constrains α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes isEmpty :: "'p ⇒ bool"
assumes isEmpty_correct:
"invar p ⟹ (isEmpty p) = (α p = {#})"
subsubsection "Find Minimal Element"
locale prio_find = prio +
constrains α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes find :: "'p ⇒ ('e × 'a::linorder)"
assumes find_correct: "⟦invar p; α p ≠ {#}⟧ ⟹
(find p) ∈# (α p) ∧ (∀y ∈ set_mset (α p). snd (find p) ≤ snd y)"
subsubsection "Insert"
locale prio_insert = prio +
constrains α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes insert :: "'e ⇒ 'a ⇒ 'p ⇒ 'p"
assumes insert_correct:
"invar p ⟹ invar (insert e a p)"
"invar p ⟹ α (insert e a p) = (α p) + {#(e,a)#}"
subsubsection "Meld Two Queues"
locale prio_meld = prio +
constrains α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes meld :: "'p ⇒ 'p ⇒ 'p"
assumes meld_correct:
"⟦invar p; invar p'⟧ ⟹ invar (meld p p')"
"⟦invar p; invar p'⟧ ⟹ α (meld p p') = (α p) + (α p')"
subsubsection "Delete Minimal Element"
text ‹Delete the same element that find will return›
locale prio_delete = prio_find +
constrains α :: "'p ⇒ ('e × 'a::linorder) multiset"
fixes delete :: "'p ⇒ 'p"
assumes delete_correct:
"⟦invar p; α p ≠ {#}⟧ ⟹ invar (delete p)"
"⟦invar p; α p ≠ {#}⟧ ⟹ α (delete p) = (α p) - {# (find p) #}"
subsection "Record based interface"
record ('e, 'a, 'p) prio_ops =
prio_op_α :: "'p ⇒ ('e × 'a) multiset"
prio_op_invar :: "'p ⇒ bool"
prio_op_empty :: "unit ⇒ 'p"
prio_op_isEmpty :: "'p ⇒ bool"
prio_op_insert :: "'e ⇒ 'a ⇒ 'p ⇒ 'p"
prio_op_find :: "'p ⇒ 'e × 'a"
prio_op_delete :: "'p ⇒ 'p"
prio_op_meld :: "'p ⇒ 'p ⇒ 'p"
locale StdPrioDefs =
fixes ops :: "('e,'a::linorder,'p) prio_ops"
begin
abbreviation α where "α == prio_op_α ops"
abbreviation invar where "invar == prio_op_invar ops"
abbreviation empty where "empty == prio_op_empty ops"
abbreviation isEmpty where "isEmpty == prio_op_isEmpty ops"
abbreviation insert where "insert == prio_op_insert ops"
abbreviation find where "find == prio_op_find ops"
abbreviation delete where "delete == prio_op_delete ops"
abbreviation meld where "meld == prio_op_meld ops"
end
locale StdPrio = StdPrioDefs ops +
prio α invar +
prio_empty α invar empty +
prio_isEmpty α invar isEmpty +
prio_find α invar find +
prio_insert α invar insert +
prio_meld α invar meld +
prio_delete α invar find delete
for ops
begin
lemmas correct =
empty_correct
isEmpty_correct
find_correct
insert_correct
meld_correct
delete_correct
end
locale StdPrio_no_invar = StdPrio + prio_no_invar α invar
end
Theory PrioUniqueSpec
section ‹\isaheader{Specification of Unique Priority Queues}›
theory PrioUniqueSpec
imports ICF_Spec_Base
begin
text ‹
We define unique priority queues, where each element may occur at most once.
We provide operations to get and remove the element with the minimum priority,
as well as to access and change an elements priority (decrease-key operation).
Unique priority queues are abstracted to maps from elements to priorities.
›
locale uprio =
fixes α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes invar :: "'s ⇒ bool"
locale uprio_no_invar = uprio +
assumes invar[simp, intro!]: "⋀s. invar s"
locale uprio_finite = uprio +
assumes finite_correct:
"invar s ⟹ finite (dom (α s))"
subsection "Basic Upriority Queue Functions"
subsubsection "Empty Queue"
locale uprio_empty = uprio +
constrains α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes empty :: "unit ⇒ 's"
assumes empty_correct:
"invar (empty ())"
"α (empty ()) = Map.empty"
subsubsection "Emptiness Predicate"
locale uprio_isEmpty = uprio +
constrains α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes isEmpty :: "'s ⇒ bool"
assumes isEmpty_correct:
"invar s ⟹ (isEmpty s) = (α s = Map.empty)"
subsubsection "Find and Remove Minimal Element"
locale uprio_pop = uprio +
constrains α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes pop :: "'s ⇒ ('e × 'a × 's)"
assumes pop_correct:
"⟦invar s; α s ≠ Map.empty; pop s = (e,a,s')⟧ ⟹
invar s' ∧
α s' = (α s)(e := None) ∧
(α s) e = Some a ∧
(∀y ∈ ran (α s). a ≤ y)"
begin
lemma popE:
assumes
"invar s"
"α s ≠ Map.empty"
obtains e a s' where
"pop s = (e, a, s')"
"invar s'"
"α s' = (α s)(e := None)"
"(α s) e = Some a"
"(∀y ∈ ran (α s). a ≤ y)"
using assms
apply (cases "pop s")
apply (drule (2) pop_correct)
apply blast
done
end
subsubsection "Insert"
text ‹
If an existing element is inserted, its priority will be overwritten.
This can be used to implement a decrease-key operation.
›
locale uprio_insert = uprio +
constrains α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes insert :: "'s ⇒ 'e ⇒ 'a ⇒ 's"
assumes insert_correct:
"invar s ⟹ invar (insert s e a)"
"invar s ⟹ α (insert s e a) = (α s)(e ↦ a)"
subsubsection "Distinct Insert"
text ‹
This operation only allows insertion of elements
that are not yet in the queue.
›
locale uprio_distinct_insert = uprio +
constrains α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes insert :: "'s ⇒ 'e ⇒ 'a ⇒ 's"
assumes distinct_insert_correct:
"⟦invar s; e ∉ dom (α s)⟧ ⟹ invar (insert s e a)"
"⟦invar s; e ∉ dom (α s)⟧ ⟹ α (insert s e a) = (α s)(e ↦ a)"
subsubsection "Looking up Priorities"
locale uprio_prio = uprio +
constrains α :: "'s ⇒ ('e ⇀ 'a::linorder)"
fixes prio :: "'s ⇒ 'e ⇒ 'a option"
assumes prio_correct:
"invar s ⟹ prio s e = (α s) e"
subsection "Record Based Interface"
record ('e, 'a, 's) uprio_ops =
upr_α :: "'s ⇒ ('e ⇀ 'a)"
upr_invar :: "'s ⇒ bool"
upr_empty :: "unit ⇒ 's"
upr_isEmpty :: "'s ⇒ bool"
upr_insert :: "'s ⇒ 'e ⇒ 'a ⇒ 's"
upr_pop :: "'s ⇒ ('e × 'a × 's)"
upr_prio :: "'s ⇒ 'e ⇒ 'a option"
locale StdUprioDefs =
fixes ops :: "('e,'a::linorder,'s, 'more) uprio_ops_scheme"
begin
abbreviation α where "α == upr_α ops"
abbreviation invar where "invar == upr_invar ops"
abbreviation empty where "empty == upr_empty ops"
abbreviation isEmpty where "isEmpty == upr_isEmpty ops"
abbreviation insert where "insert == upr_insert ops"
abbreviation pop where "pop == upr_pop ops"
abbreviation prio where "prio == upr_prio ops"
end
locale StdUprio = StdUprioDefs ops +
uprio_finite α invar +
uprio_empty α invar empty +
uprio_isEmpty α invar isEmpty +
uprio_insert α invar insert +
uprio_pop α invar pop +
uprio_prio α invar prio
for ops
begin
lemmas correct =
finite_correct
empty_correct
isEmpty_correct
insert_correct
prio_correct
end
locale StdUprio_no_invar = StdUprio + uprio_no_invar α invar
end
Theory ICF_Gen_Algo_Chapter
theory ICF_Gen_Algo_Chapter imports Main begin
text_raw ‹\isasection{Generic Algorithms} \label{ch:GA}›
end
Theory SetIteratorCollectionsGA
section ‹General Algorithms for Iterators over Finite Sets›
theory SetIteratorCollectionsGA
imports
"../spec/SetSpec"
"../spec/MapSpec"
begin
subsection ‹Iterate add to Set›
definition iterate_add_to_set where
"iterate_add_to_set s ins (it::('x,'x_set) set_iterator) =
it (λ_. True) (λx σ. ins x σ) s"
lemma iterate_add_to_set_correct :
assumes ins_OK: "set_ins α invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "α (iterate_add_to_set s ins it) = S0 ∪ α s ∧ invar (iterate_add_to_set s ins it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
where ?I="λS σ. α σ = S ∪ α s ∧ invar σ"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def)
done
lemma iterate_add_to_set_dj_correct :
assumes ins_dj_OK: "set_ins_dj α invar ins_dj"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "S0 ∩ α s = {}"
shows "α (iterate_add_to_set s ins_dj it) = S0 ∪ α s ∧ invar (iterate_add_to_set s ins_dj it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
where ?I="λS σ. α σ = S ∪ α s ∧ invar σ"])
apply (insert ins_dj_OK s_OK dj)
apply (simp_all add: set_ins_dj_def set_eq_iff)
done
subsection ‹Iterator to Set›
definition iterate_to_set where
"iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) =
iterate_add_to_set (emp ()) ins_dj it"
lemma iterate_to_set_alt_def[code] :
"iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) =
it (λ_. True) (λx σ. ins_dj x σ) (emp ())"
unfolding iterate_to_set_def iterate_add_to_set_def by simp
lemma iterate_to_set_correct :
assumes ins_dj_OK: "set_ins_dj α invar ins_dj"
assumes emp_OK: "set_empty α invar emp"
assumes it: "set_iterator it S0"
shows "α (iterate_to_set emp ins_dj it) = S0 ∧ invar (iterate_to_set emp ins_dj it)"
unfolding iterate_to_set_def
using iterate_add_to_set_dj_correct [OF ins_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: set_empty_def)
subsection ‹Iterate image/filter add to Set›
text ‹Iterators only visit element once. Therefore the image operations makes sense for
filters only if an injective function is used. However, when adding to a set using
non-injective functions is fine.›
lemma iterate_image_filter_add_to_set_correct :
assumes ins_OK: "set_ins α invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "α (iterate_add_to_set s ins (set_iterator_image_filter f it)) =
{b . ∃a. a ∈ S0 ∧ f a = Some b} ∪ α s ∧
invar (iterate_add_to_set s ins (set_iterator_image_filter f it))"
unfolding iterate_add_to_set_def set_iterator_image_filter_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
where ?I="λS σ. α σ = {b . ∃a. a ∈ S ∧ f a = Some b} ∪ α s ∧ invar σ"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def split: option.split)
apply auto
done
lemma iterate_image_filter_to_set_correct :
assumes ins_OK: "set_ins α invar ins"
assumes emp_OK: "set_empty α invar emp"
assumes it: "set_iterator it S0"
shows "α (iterate_to_set emp ins (set_iterator_image_filter f it)) =
{b . ∃a. a ∈ S0 ∧ f a = Some b} ∧
invar (iterate_to_set emp ins (set_iterator_image_filter f it))"
unfolding iterate_to_set_def
using iterate_image_filter_add_to_set_correct [OF ins_OK _ it, of "emp ()" f] emp_OK
by (simp add: set_empty_def)
text‹For completeness lets also consider injective versions.›
lemma iterate_inj_image_filter_add_to_set_correct :
assumes ins_dj_OK: "set_ins_dj α invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "{y. ∃x. x ∈ S0 ∧ f x = Some y} ∩ α s = {}"
assumes f_inj_on: "inj_on f (S0 ∩ dom f)"
shows "α (iterate_add_to_set s ins (set_iterator_image_filter f it)) =
{b . ∃a. a ∈ S0 ∧ f a = Some b} ∪ α s ∧
invar (iterate_add_to_set s ins (set_iterator_image_filter f it))"
proof -
from set_iterator_image_filter_correct [OF it f_inj_on]
have it_f: "set_iterator (set_iterator_image_filter f it)
{y. ∃x. x ∈ S0 ∧ f x = Some y}" by simp
from iterate_add_to_set_dj_correct [OF ins_dj_OK, OF s_OK it_f dj]
show ?thesis by auto
qed
lemma iterate_inj_image_filter_to_set_correct :
assumes ins_OK: "set_ins_dj α invar ins"
assumes emp_OK: "set_empty α invar emp"
assumes it: "set_iterator it S0"
assumes f_inj_on: "inj_on f (S0 ∩ dom f)"
shows "α (iterate_to_set emp ins (set_iterator_image_filter f it)) =
{b . ∃a. a ∈ S0 ∧ f a = Some b} ∧
invar (iterate_to_set emp ins (set_iterator_image_filter f it))"
unfolding iterate_to_set_def
using iterate_inj_image_filter_add_to_set_correct [OF ins_OK _ it _ f_inj_on, of "emp ()"] emp_OK
by (simp add: set_empty_def)
subsection ‹Iterate diff Set›
definition iterate_diff_set where
"iterate_diff_set s del (it::('x,'x_set) set_iterator) =
it (λ_. True) (λx σ. del x σ) s"
lemma iterate_diff_correct :
assumes del_OK: "set_delete α invar del"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "α (iterate_diff_set s del it) = α s - S0 ∧ invar (iterate_diff_set s del it)"
unfolding iterate_diff_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
where ?I="λS σ. α σ = α s - S ∧ invar σ"])
apply (insert del_OK s_OK)
apply (auto simp add: set_delete_def set_eq_iff)
done
subsection ‹Iterate add to Map›
definition iterate_add_to_map where
"iterate_add_to_map m update (it::('k × 'v,'kv_map) set_iterator) =
it (λ_. True) (λ(k,v) σ. update k v σ) m"
lemma iterate_add_to_map_correct :
assumes upd_OK: "map_update α invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
shows "α (iterate_add_to_map m upd it) = α m ++ M ∧ invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
where ?I="λd σ. (α σ = α m ++ M |` d) ∧ invar σ"])
apply (simp_all add: map_update_def restrict_map_insert)
done
lemma iterate_add_to_map_dj_correct :
assumes upd_OK: "map_update_dj α invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
assumes dj: "dom M ∩ dom (α m) = {}"
shows "α (iterate_add_to_map m upd it) = α m ++ M ∧ invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
where ?I="λd σ. (α σ = α m ++ M |` d) ∧ invar σ"])
apply (simp_all add: map_update_dj_def restrict_map_insert set_eq_iff)
done
subsection ‹Iterator to Map›
definition iterate_to_map where
"iterate_to_map emp upd_dj (it::('k × 'v,'kv_map) set_iterator) =
iterate_add_to_map (emp ()) upd_dj it"
lemma iterate_to_map_alt_def[code] :
"iterate_to_map emp upd_dj it =
it (λ_. True) (λ(k, v) σ. upd_dj k v σ) (emp ())"
unfolding iterate_to_map_def iterate_add_to_map_def by simp
lemma iterate_to_map_correct :
assumes upd_dj_OK: "map_update_dj α invar upd_dj"
assumes emp_OK: "map_empty α invar emp"
assumes it: "map_iterator it M"
shows "α (iterate_to_map emp upd_dj it) = M ∧ invar (iterate_to_map emp upd_dj it)"
unfolding iterate_to_map_def
using iterate_add_to_map_dj_correct [OF upd_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: map_empty_def)
end
Theory MapGA
section ‹\isaheader{Generic Algorithms for Maps}›
theory MapGA
imports SetIteratorCollectionsGA
begin
text_raw ‹\label{thy:MapGA}›
record ('k,'v,'s) map_basic_ops =
bmap_op_α :: "('k,'v,'s) map_α"
bmap_op_invar :: "('k,'v,'s) map_invar"
bmap_op_empty :: "('k,'v,'s) map_empty"
bmap_op_lookup :: "('k,'v,'s) map_lookup"
bmap_op_update :: "('k,'v,'s) map_update"
bmap_op_update_dj :: "('k,'v,'s) map_update_dj"
bmap_op_delete :: "('k,'v,'s) map_delete"
bmap_op_list_it :: "('k,'v,'s) map_list_it"
record ('k,'v,'s) omap_basic_ops = "('k,'v,'s) map_basic_ops" +
bmap_op_ordered_list_it :: "'s ⇒ ('k,'v,('k×'v) list) map_iterator"
bmap_op_rev_list_it :: "'s ⇒ ('k,'v,('k×'v) list) map_iterator"
locale StdBasicMapDefs =
poly_map_iteratei_defs "bmap_op_list_it ops"
for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
abbreviation α where "α == bmap_op_α ops"
abbreviation invar where "invar == bmap_op_invar ops"
abbreviation empty where "empty == bmap_op_empty ops"
abbreviation lookup where "lookup == bmap_op_lookup ops"
abbreviation update where "update == bmap_op_update ops"
abbreviation update_dj where "update_dj == bmap_op_update_dj ops"
abbreviation delete where "delete == bmap_op_delete ops"
abbreviation list_it where "list_it == bmap_op_list_it ops"
end
locale StdBasicOMapDefs = StdBasicMapDefs ops
+ poly_map_iterateoi_defs "bmap_op_ordered_list_it ops"
+ poly_map_rev_iterateoi_defs "bmap_op_rev_list_it ops"
for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
abbreviation ordered_list_it where "ordered_list_it
≡ bmap_op_ordered_list_it ops"
abbreviation rev_list_it where "rev_list_it
≡ bmap_op_rev_list_it ops"
end
locale StdBasicMap = StdBasicMapDefs ops +
map α invar +
map_empty α invar empty +
map_lookup α invar lookup +
map_update α invar update +
map_update_dj α invar update_dj +
map_delete α invar delete +
poly_map_iteratei α invar list_it
for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
lemmas correct[simp] = empty_correct lookup_correct update_correct
update_dj_correct delete_correct
end
locale StdBasicOMap =
StdBasicOMapDefs ops +
StdBasicMap ops +
poly_map_iterateoi α invar ordered_list_it +
poly_map_rev_iterateoi α invar rev_list_it
for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
end
context StdBasicMapDefs begin
definition "g_sng k v ≡ update k v (empty ())"
definition "g_add m1 m2 ≡ iterate m2 (λ(k,v) σ. update k v σ) m1"
definition
"g_sel m P ≡
iteratei m (λσ. σ = None) (λx σ. if P x then Some x else None) None"
definition "g_bex m P ≡ iteratei m (λx. ¬x) (λkv σ. P kv) False"
definition "g_ball m P ≡ iteratei m id (λkv σ. P kv) True"
definition "g_size m ≡ iterate m (λ_. Suc) (0::nat)"
definition "g_size_abort b m ≡ iteratei m (λs. s<b) (λ_. Suc) (0::nat)"
definition "g_isEmpty m ≡ g_size_abort 1 m = 0"
definition "g_isSng m ≡ g_size_abort 2 m = 1"
definition "g_to_list m ≡ iterate m (#) []"
definition "g_list_to_map l ≡ foldl (λm (k,v). update k v m) (empty ())
(rev l)"
definition "g_add_dj m1 m2 ≡ iterate m2 (λ(k,v) σ. update_dj k v σ) m1"
definition "g_restrict P m ≡ iterate m
(λ(k,v) σ. if P (k,v) then update_dj k v σ else σ) (empty ())"
definition dflt_ops :: "('k,'v,'s) map_ops"
where [icf_rec_def]:
"dflt_ops ≡
⦇
map_op_α = α,
map_op_invar = invar,
map_op_empty = empty,
map_op_lookup = lookup,
map_op_update = update,
map_op_update_dj = update_dj,
map_op_delete = delete,
map_op_list_it = list_it,
map_op_sng = g_sng,
map_op_restrict = g_restrict,
map_op_add = g_add,
map_op_add_dj = g_add_dj,
map_op_isEmpty = g_isEmpty,
map_op_isSng = g_isSng,
map_op_ball = g_ball,
map_op_bex = g_bex,
map_op_size = g_size,
map_op_size_abort = g_size_abort,
map_op_sel = g_sel,
map_op_to_list = g_to_list,
map_op_to_map = g_list_to_map
⦈"
local_setup ‹Locale_Code.lc_decl_del @{term dflt_ops}›
end
lemma update_dj_by_update:
assumes "map_update α invar update"
shows "map_update_dj α invar update"
proof -
interpret map_update α invar update by fact
show ?thesis
apply (unfold_locales)
apply (auto simp add: update_correct)
done
qed
lemma map_iterator_linord_is_it:
"map_iterator_linord m it ⟹ map_iterator m it"
unfolding set_iterator_def set_iterator_map_linord_def
apply (erule set_iterator_genord.set_iterator_weaken_R)
..
lemma map_rev_iterator_linord_is_it:
"map_iterator_rev_linord m it ⟹ map_iterator m it"
unfolding set_iterator_def set_iterator_map_rev_linord_def
apply (erule set_iterator_genord.set_iterator_weaken_R)
..
context StdBasicMap
begin
lemma g_sng_impl: "map_sng α invar g_sng"
apply unfold_locales
apply (simp_all add: update_correct empty_correct g_sng_def)
done
lemma g_add_impl: "map_add α invar g_add"
proof
fix m1 m2
assume "invar m1" "invar m2"
have A: "g_add m1 m2 = iterate_add_to_map m1 update (iteratei m2)"
unfolding g_add_def iterate_add_to_map_def by simp
have "α (g_add m1 m2) = α m1 ++ α m2 ∧ invar (g_add m1 m2)"
unfolding A
apply (rule
iterate_add_to_map_correct[of α invar update m1 "iteratei m2" "α m2"])
apply unfold_locales []
apply fact
apply (rule iteratei_correct, fact)
done
thus "α (g_add m1 m2) = α m1 ++ α m2" "invar (g_add m1 m2)" by auto
qed
lemma g_sel_impl: "map_sel' α invar g_sel"
proof -
have A: "⋀m P. g_sel m P = iterate_sel_no_map (iteratei m) P"
unfolding g_sel_def iterate_sel_no_map_def iterate_sel_def by simp
{ fix m P
assume I: "invar m"
note iterate_sel_no_map_correct[OF iteratei_correct[OF I], of P]
}
thus ?thesis
apply unfold_locales
unfolding A
apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
apply clarify
apply (metis option.exhaust prod.exhaust)
apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
done
qed
lemma g_bex_impl: "map_bex α invar g_bex"
apply unfold_locales
unfolding g_bex_def
apply (rule_tac I="λit σ. σ ⟷ (∃kv∈it. P kv)"
in iteratei_rule_insert_P)
by (auto simp: map_to_set_def)
lemma g_ball_impl: "map_ball α invar g_ball"
apply unfold_locales
unfolding g_ball_def
apply (rule_tac I="λit σ. σ ⟷ (∀kv∈it. P kv)"
in iteratei_rule_insert_P)
apply (auto simp: map_to_set_def)
done
lemma g_size_impl: "map_size α invar g_size"
proof
fix m
assume I: "invar m"
have A: "g_size m ≡ iterate_size (iteratei m)"
unfolding g_size_def iterate_size_def by simp
from iterate_size_correct [OF iteratei_correct[OF I]]
show "g_size m = card (dom (α m))"
unfolding A
by (simp_all add: card_map_to_set)
qed
lemma g_size_abort_impl: "map_size_abort α invar g_size_abort"
proof
fix s m
assume I: "invar m"
have A: "g_size_abort s m ≡ iterate_size_abort (iteratei m) s"
unfolding g_size_abort_def iterate_size_abort_def by simp
from iterate_size_abort_correct [OF iteratei_correct[OF I]]
show "g_size_abort s m = min s (card (dom (α m)))"
unfolding A
by (simp_all add: card_map_to_set)
qed
lemma g_isEmpty_impl: "map_isEmpty α invar g_isEmpty"
proof
fix m
assume I: "invar m"
interpret map_size_abort α invar g_size_abort by (rule g_size_abort_impl)
from size_abort_correct[OF I] have
"g_size_abort 1 m = min 1 (card (dom (α m)))" .
thus "g_isEmpty m = (α m = Map.empty)" unfolding g_isEmpty_def
by (auto simp: min_def card_0_eq[OF finite] I)
qed
lemma g_isSng_impl: "map_isSng α invar g_isSng"
proof
fix m
assume I: "invar m"
interpret map_size_abort α invar g_size_abort by (rule g_size_abort_impl)
from size_abort_correct[OF I] have
"g_size_abort 2 m = min 2 (card (dom (α m)))" .
thus "g_isSng m = (∃k v. α m = [k ↦ v])" unfolding g_isSng_def
by (auto simp: min_def I card_Suc_eq dom_eq_singleton_conv)
qed
lemma g_to_list_impl: "map_to_list α invar g_to_list"
proof
fix m
assume I: "invar m"
have A: "g_to_list m = iterate_to_list (iteratei m)"
unfolding g_to_list_def iterate_to_list_def by simp
from iterate_to_list_correct [OF iteratei_correct[OF I]]
have set_l_eq: "set (g_to_list m) = map_to_set (α m)" and
dist_l: "distinct (g_to_list m)" unfolding A by simp_all
from dist_l show dist_fst_l: "distinct (map fst (g_to_list m))"
by (simp add: distinct_map set_l_eq map_to_set_def inj_on_def)
from map_of_map_to_set[of "(g_to_list m)" "α m", OF dist_fst_l] set_l_eq
show "map_of (g_to_list m) = α m" by simp
qed
lemma g_list_to_map_impl: "list_to_map α invar g_list_to_map"
proof -
{
fix m0 l
assume "invar m0"
hence "invar (foldl (λs (k,v). update k v s) m0 l) ∧
α (foldl (λs (k,v). update k v s) m0 l) = α m0 ++ map_of (rev l)"
proof (induction l arbitrary: m0)
case Nil thus ?case by simp
next
case (Cons kv l)
obtain k v where [simp]: "kv=(k,v)" by (cases kv) auto
have "invar (foldl (λs (k, v). update k v s) m0 (kv # l))"
apply simp
apply (rule conjunct1[OF Cons.IH])
apply (simp add: update_correct Cons.prems)
done
moreover have "α (foldl (λs (k, v). update k v s) m0 (kv # l)) =
α m0 ++ map_of (rev (kv # l))"
apply simp
apply (rule trans[OF conjunct2[OF Cons.IH]])
apply (auto
simp: update_correct Cons.prems Map.map_add_def[abs_def]
split: option.split
)
done
ultimately show ?case
by simp
qed
} thus ?thesis
apply unfold_locales
unfolding g_list_to_map_def
apply (auto simp: empty_correct)
done
qed
lemma g_add_dj_impl: "map_add_dj α invar g_add_dj"
proof
fix m1 m2
assume "invar m1" "invar m2" and DJ: "dom (α m1) ∩ dom (α m2) = {}"
have A: "g_add_dj m1 m2 = iterate_add_to_map m1 update_dj (iteratei m2)"
unfolding g_add_dj_def iterate_add_to_map_def by simp
have "α (g_add_dj m1 m2) = α m1 ++ α m2 ∧ invar (g_add_dj m1 m2)"
unfolding A
apply (rule
iterate_add_to_map_dj_correct[
of α invar update_dj m1 "iteratei m2" "α m2"])
apply unfold_locales []
apply fact
apply (rule iteratei_correct, fact)
using DJ apply (simp add: Int_ac)
done
thus "α (g_add_dj m1 m2) = α m1 ++ α m2" "invar (g_add_dj m1 m2)" by auto
qed
lemma g_restrict_impl: "map_restrict α invar α invar g_restrict"
proof
fix m P
assume I: "invar m"
have AUX: "⋀k v it σ.
⟦it ⊆ {(k, v). α m k = Some v}; α m k = Some v; (k, v) ∉ it;
{(k, v). α σ k = Some v} = it ∩ Collect P⟧
⟹ k ∉ dom (α σ)"
proof (rule ccontr, simp)
fix k v it σ
assume "k∈dom (α σ)"
then obtain v' where "α σ k = Some v'" by auto
moreover assume "{(k, v). α σ k = Some v} = it ∩ Collect P"
ultimately have MEM: "(k,v')∈it" by auto
moreover assume "it ⊆ {(k, v). α m k = Some v}" and "α m k = Some v"
ultimately have "v'=v" by auto
moreover assume "(k,v)∉it"
moreover note MEM
ultimately show False by simp
qed
have "α (g_restrict P m) = α m |` {k. ∃v. α m k = Some v ∧ P (k, v)} ∧
invar (g_restrict P m)"
unfolding g_restrict_def
apply (rule_tac I="λit σ. invar σ
∧ map_to_set (α σ) = it ∩ Collect P"
in iterate_rule_insert_P)
apply (auto simp: I empty_correct update_dj_correct map_to_set_def AUX)
apply (auto split: if_split_asm)
apply (rule ext)
apply (auto simp: Map.restrict_map_def)
apply force
apply (rule ccontr)
apply force
done
thus "α (g_restrict P m) = α m |` {k. ∃v. α m k = Some v ∧ P (k, v)}"
"invar (g_restrict P m)" by auto
qed
lemma dflt_ops_impl: "StdMap dflt_ops"
apply (rule StdMap_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (rule g_sng_impl g_restrict_impl g_add_impl g_add_dj_impl
g_isEmpty_impl g_isSng_impl g_ball_impl g_bex_impl g_size_impl
g_size_abort_impl g_sel_impl g_to_list_impl g_list_to_map_impl)+
done
end
context StdBasicOMapDefs
begin
definition
"g_min m P ≡
iterateoi m (λσ. σ = None) (λx σ. if P x then Some x else None) None"
definition
"g_max m P ≡
rev_iterateoi m (λσ. σ = None) (λx σ. if P x then Some x else None) None"
definition "g_to_sorted_list m ≡ rev_iterateo m (#) []"
definition "g_to_rev_list m ≡ iterateo m (#) []"
definition dflt_oops :: "('k,'v,'s) omap_ops"
where [icf_rec_def]:
"dflt_oops ≡ map_ops.extend dflt_ops
⦇
map_op_ordered_list_it = ordered_list_it,
map_op_rev_list_it = rev_list_it,
map_op_min = g_min,
map_op_max = g_max,
map_op_to_sorted_list = g_to_sorted_list,
map_op_to_rev_list = g_to_rev_list
⦈"
local_setup ‹Locale_Code.lc_decl_del @{term dflt_oops}›
end
context StdBasicOMap
begin
lemma g_min_impl: "map_min α invar g_min"
proof
fix m P
assume I: "invar m"
from iterateoi_correct[OF I]
have iti': "map_iterator_linord (iterateoi m) (α m)" by simp
note sel_correct = iterate_sel_no_map_map_linord_correct[OF iti', of P]
have A: "g_min m P = iterate_sel_no_map (iterateoi m) P"
unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp
{ assume "rel_of (α m) P ≠ {}"
with sel_correct
show "g_min m P ∈ Some ` rel_of (α m) P"
unfolding A
by (auto simp add: image_iff rel_of_def)
}
{ assume "rel_of (α m) P = {}"
with sel_correct show "g_min m P = None"
unfolding A
by (auto simp add: image_iff rel_of_def)
}
{ fix k v
assume "(k, v) ∈ rel_of (α m) P"
with sel_correct show "fst (the (g_min m P)) ≤ k"
unfolding A
by (auto simp add: image_iff rel_of_def)
}
qed
lemma g_max_impl: "map_max α invar g_max"
proof
fix m P
assume I: "invar m"
from rev_iterateoi_correct[OF I]
have iti': "map_iterator_rev_linord (rev_iterateoi m) (α m)" by simp
note sel_correct = iterate_sel_no_map_map_rev_linord_correct[OF iti', of P]
have A: "g_max m P = iterate_sel_no_map (rev_iterateoi m) P"
unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp
{ assume "rel_of (α m) P ≠ {}"
with sel_correct
show "g_max m P ∈ Some ` rel_of (α m) P"
unfolding A
by (auto simp add: image_iff rel_of_def)
}
{ assume "rel_of (α m) P = {}"
with sel_correct show "g_max m P = None"
unfolding A
by (auto simp add: image_iff rel_of_def)
}
{ fix k v
assume "(k, v) ∈ rel_of (α m) P"
with sel_correct show "fst (the (g_max m P)) ≥ k"
unfolding A
by (auto simp add: image_iff rel_of_def)
}
qed
lemma g_to_sorted_list_impl: "map_to_sorted_list α invar g_to_sorted_list"
proof
fix m
assume I: "invar m"
note iti = rev_iterateoi_correct[OF I]
from iterate_to_list_map_rev_linord_correct[OF iti]
show "sorted (map fst (g_to_sorted_list m))"
"distinct (map fst (g_to_sorted_list m))"
"map_of (g_to_sorted_list m) = α m"
unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
qed
lemma g_to_rev_list_impl: "map_to_rev_list α invar g_to_rev_list"
proof
fix m
assume I: "invar m"
note iti = iterateoi_correct[OF I]
from iterate_to_list_map_linord_correct[OF iti]
show "sorted (rev (map fst (g_to_rev_list m)))"
"distinct (map fst (g_to_rev_list m))"
"map_of (g_to_rev_list m) = α m"
unfolding g_to_rev_list_def iterate_to_list_def
by (simp_all add: rev_map)
qed
lemma dflt_oops_impl: "StdOMap dflt_oops"
proof -
interpret aux: StdMap dflt_ops by (rule dflt_ops_impl)
show ?thesis
apply (rule StdOMap_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (rule g_min_impl)
apply (rule g_max_impl)
apply (rule g_to_sorted_list_impl)
apply (rule g_to_rev_list_impl)
done
qed
end
locale g_image_filter_defs_loc =
m1: StdMapDefs ops1 +
m2: StdMapDefs ops2
for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
definition "g_image_filter f m1 ≡ m1.iterate m1 (λkv σ. case f kv of
None => σ
| Some (k',v') => m2.update_dj k' v' σ
) (m2.empty ())"
end
locale g_image_filter_loc = g_image_filter_defs_loc ops1 ops2 +
m1: StdMap ops1 +
m2: StdMap ops2
for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
lemma g_image_filter_impl:
"map_image_filter m1.α m1.invar m2.α m2.invar g_image_filter"
proof
fix m k' v' and f :: "('k1 × 'v1) ⇒ ('k2 × 'v2) option"
assume invar_m: "m1.invar m" and
unique_f: "transforms_to_unique_keys (m1.α m) f"
have A: "g_image_filter f m =
iterate_to_map m2.empty m2.update_dj (
set_iterator_image_filter f (m1.iteratei m))"
unfolding g_image_filter_def iterate_to_map_alt_def
set_iterator_image_filter_def case_prod_beta
by simp
from m1.iteratei_correct[OF invar_m]
have iti_m: "map_iterator (m1.iteratei m) (m1.α m)" by simp
from unique_f have inj_on_f: "inj_on f (map_to_set (m1.α m) ∩ dom f)"
unfolding transforms_to_unique_keys_def inj_on_def Ball_def map_to_set_def
by auto (metis option.inject)
define vP where "vP k v ⟷ (∃k' v'. m1.α m k' = Some v' ∧ f (k', v') = Some (k, v))" for k v
have vP_intro: "⋀k v. (∃k' v'. m1.α m k' = Some v'
∧ f (k', v') = Some (k, v)) ⟷ vP k v"
unfolding vP_def by simp
{ fix k v
have "Eps_Opt (vP k) = Some v ⟷ vP k v"
using unique_f unfolding vP_def transforms_to_unique_keys_def
apply (rule_tac Eps_Opt_eq_Some)
apply (metis prod.inject option.inject)
done
} note Eps_vP_elim[simp] = this
have map_intro: "{y. ∃x. x ∈ map_to_set (m1.α m) ∧ f x = Some y}
= map_to_set (λk. Eps_Opt (vP k))"
by (simp add: map_to_set_def vP_intro set_eq_iff split: prod.splits)
from set_iterator_image_filter_correct [OF iti_m, OF inj_on_f,
unfolded map_intro]
have iti_filter: "map_iterator (set_iterator_image_filter f (m1.iteratei m))
(λk. Eps_Opt (vP k))" by auto
have upd: "map_update_dj m2.α m2.invar m2.update_dj" by unfold_locales
have emp: "map_empty m2.α m2.invar m2.empty" by unfold_locales
from iterate_to_map_correct[OF upd emp iti_filter] show
"map_op_invar ops2 (g_image_filter f m) ∧
(map_op_α ops2 (g_image_filter f m) k' = Some v') =
(∃k v. map_op_α ops1 m k = Some v ∧ f (k, v) = Some (k', v'))"
unfolding A vP_def[symmetric]
by (simp add: vP_intro)
qed
end
sublocale g_image_filter_loc
< map_image_filter m1.α m1.invar m2.α m2.invar g_image_filter
by (rule g_image_filter_impl)
locale g_value_image_filter_defs_loc =
m1: StdMapDefs ops1 +
m2: StdMapDefs ops2
for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
definition "g_value_image_filter f m1 ≡ m1.iterate m1 (λ(k,v) σ.
case f k v of
None => σ
| Some v' => m2.update_dj k v' σ
) (m2.empty ())"
end
lemma restrict_map_dom_subset: "⟦ dom m ⊆ R⟧ ⟹ m|`R = m"
apply (rule ext)
apply (auto simp: restrict_map_def)
apply (case_tac "m x")
apply auto
done
locale g_value_image_filter_loc = g_value_image_filter_defs_loc ops1 ops2 +
m1: StdMap ops1 +
m2: StdMap ops2
for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
lemma g_value_image_filter_impl:
"map_value_image_filter m1.α m1.invar m2.α m2.invar g_value_image_filter"
apply unfold_locales
unfolding g_value_image_filter_def
apply (rule_tac I="λit σ. m2.invar σ
∧ m2.α σ = (λk. Option.bind (map_op_α ops1 m k) (f k)) |` it"
in m1.old_iterate_rule_insert_P)
apply auto []
apply (auto simp: m2.empty_correct) []
defer
apply simp []
apply (rule restrict_map_dom_subset)
apply (auto) []
apply (case_tac "m1.α m x")
apply (auto) [2]
apply (auto split: option.split simp: m2.update_dj_correct intro!: ext)
apply (auto simp: restrict_map_def)
done
end
sublocale g_value_image_filter_loc
< map_value_image_filter m1.α m1.invar m2.α m2.invar g_value_image_filter
by (rule g_value_image_filter_impl)
end
Theory SetGA
section ‹\isaheader{Generic Algorithms for Sets}›
theory SetGA
imports "../spec/SetSpec" SetIteratorCollectionsGA
begin
text_raw ‹\label{thy:SetGA}›
subsection ‹Generic Set Algorithms›
locale g_set_xx_defs_loc =
s1: StdSetDefs ops1 + s2: StdSetDefs ops2
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
definition "g_copy s ≡ s1.iterate s s2.ins_dj (s2.empty ())"
definition "g_filter P s1 ≡ s1.iterate s1
(λx σ. if P x then s2.ins_dj x σ else σ)
(s2.empty ())"
definition "g_union s1 s2 ≡ s1.iterate s1 s2.ins s2"
definition "g_diff s1 s2 ≡ s2.iterate s2 s1.delete s1"
definition g_union_list where
"g_union_list l =
foldl (λs s'. g_union s' s) (s2.empty ()) l"
definition "g_union_dj s1 s2 ≡ s1.iterate s1 s2.ins_dj s2"
definition "g_disjoint_witness s1 s2 ≡
s1.sel s1 (λx. s2.memb x s2)"
definition "g_disjoint s1 s2 ≡
s1.ball s1 (λx. ¬s2.memb x s2)"
end
locale g_set_xx_loc = g_set_xx_defs_loc ops1 ops2 +
s1: StdSet ops1 + s2: StdSet ops2
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
lemma g_copy_alt:
"g_copy s = iterate_to_set s2.empty s2.ins_dj (s1.iteratei s)"
unfolding iterate_to_set_alt_def g_copy_def ..
lemma g_copy_impl: "set_copy s1.α s1.invar s2.α s2.invar g_copy"
proof -
have LIS:
"set_ins_dj s2.α s2.invar s2.ins_dj"
"set_empty s2.α s2.invar s2.empty"
by unfold_locales
from iterate_to_set_correct[OF LIS s1.iteratei_correct]
show ?thesis
apply unfold_locales
unfolding g_copy_alt
by simp_all
qed
lemma g_filter_impl: "set_filter s1.α s1.invar s2.α s2.invar g_filter"
proof
fix s P
assume "s1.invar s"
hence "s2.α (g_filter P s) = {e ∈ s1.α s. P e} ∧
s2.invar (g_filter P s)" (is "?G1 ∧ ?G2")
unfolding g_filter_def
apply (rule_tac I="λit σ. s2.invar σ ∧ s2.α σ = {e ∈ it. P e}"
in s1.iterate_rule_insert_P)
by (auto simp add: s2.empty_correct s2.ins_dj_correct)
thus ?G1 ?G2 by auto
qed
lemma g_union_alt:
"g_union s1 s2 = iterate_add_to_set s2 s2.ins (s1.iteratei s1)"
unfolding iterate_add_to_set_def g_union_def ..
lemma g_diff_alt:
"g_diff s1 s2 = iterate_diff_set s1 s1.delete (s2.iteratei s2)"
unfolding g_diff_def iterate_diff_set_def ..
lemma g_union_impl:
"set_union s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union"
proof -
have LIS: "set_ins s2.α s2.invar s2.ins" by unfold_locales
from iterate_add_to_set_correct[OF LIS _ s1.iteratei_correct]
show ?thesis
apply unfold_locales
unfolding g_union_alt
by simp_all
qed
lemma g_diff_impl:
"set_diff s1.α s1.invar s2.α s2.invar g_diff"
proof -
have LIS: "set_delete s1.α s1.invar s1.delete" by unfold_locales
from iterate_diff_correct[OF LIS _ s2.iteratei_correct]
show ?thesis
apply unfold_locales
unfolding g_diff_alt
by simp_all
qed
lemma g_union_list_impl:
shows "set_union_list s1.α s1.invar s2.α s2.invar g_union_list"
proof
fix l
note correct = s2.empty_correct set_union.union_correct[OF g_union_impl]
assume "∀s1∈set l. s1.invar s1"
hence aux: "⋀s. s2.invar s ⟹
s2.α (foldl (λs s'. g_union s' s) s l)
= ⋃{s1.α s1 |s1. s1 ∈ set l} ∪ s2.α s ∧
s2.invar (foldl (λs s'. g_union s' s) s l)"
by (induct l) (auto simp add: correct)
from aux [of "s2.empty ()"]
show "s2.α (g_union_list l) = ⋃{s1.α s1 |s1. s1 ∈ set l}"
"s2.invar (g_union_list l)"
unfolding g_union_list_def
by (simp_all add: correct)
qed
lemma g_union_dj_impl:
"set_union_dj s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union_dj"
proof
fix s1 s2
assume I:
"s1.invar s1"
"s2.invar s2"
assume DJ: "s1.α s1 ∩ s2.α s2 = {}"
have "s2.α (g_union_dj s1 s2)
= s1.α s1 ∪ s2.α s2
∧ s2.invar (g_union_dj s1 s2)" (is "?G1 ∧ ?G2")
unfolding g_union_dj_def
apply (rule_tac I="λit σ. s2.invar σ ∧ s2.α σ = it ∪ s2.α s2"
in s1.iterate_rule_insert_P)
using DJ
apply (simp_all add: I)
apply (subgoal_tac "x∉s2.α σ")
apply (simp add: s2.ins_dj_correct I)
apply auto
done
thus ?G1 ?G2 by auto
qed
lemma g_disjoint_witness_impl:
"set_disjoint_witness s1.α s1.invar s2.α s2.invar g_disjoint_witness"
proof -
show ?thesis
apply unfold_locales
unfolding g_disjoint_witness_def
by (auto dest: s1.sel'_noneD s1.sel'_someD simp: s2.memb_correct)
qed
lemma g_disjoint_impl:
"set_disjoint s1.α s1.invar s2.α s2.invar g_disjoint"
proof -
show ?thesis
apply unfold_locales
unfolding g_disjoint_def
by (auto simp: s2.memb_correct s1.ball_correct)
qed
end
sublocale g_set_xx_loc <
set_copy s1.α s1.invar s2.α s2.invar g_copy by (rule g_copy_impl)
sublocale g_set_xx_loc <
set_filter s1.α s1.invar s2.α s2.invar g_filter by (rule g_filter_impl)
sublocale g_set_xx_loc <
set_union s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union
by (rule g_union_impl)
sublocale g_set_xx_loc <
set_union_dj s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union_dj
by (rule g_union_dj_impl)
sublocale g_set_xx_loc <
set_diff s1.α s1.invar s2.α s2.invar g_diff
by (rule g_diff_impl)
sublocale g_set_xx_loc <
set_disjoint_witness s1.α s1.invar s2.α s2.invar g_disjoint_witness
by (rule g_disjoint_witness_impl)
sublocale g_set_xx_loc <
set_disjoint s1.α s1.invar s2.α s2.invar g_disjoint by (rule g_disjoint_impl)
locale g_set_xxx_defs_loc =
s1: StdSetDefs ops1 +
s2: StdSetDefs ops2 +
s3: StdSetDefs ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('x,'s2,'more2) set_ops_scheme"
and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
definition "g_inter s1 s2 ≡
s1.iterate s1 (λx s. if s2.memb x s2 then s3.ins_dj x s else s)
(s3.empty ())"
end
locale g_set_xxx_loc = g_set_xxx_defs_loc ops1 ops2 ops3 +
s1: StdSet ops1 +
s2: StdSet ops2 +
s3: StdSet ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('x,'s2,'more2) set_ops_scheme"
and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
lemma g_inter_impl: "set_inter s1.α s1.invar s2.α s2.invar s3.α s3.invar
g_inter"
proof
fix s1 s2
assume I:
"s1.invar s1"
"s2.invar s2"
have "s3.α (g_inter s1 s2) = s1.α s1 ∩ s2.α s2 ∧ s3.invar (g_inter s1 s2)"
unfolding g_inter_def
apply (rule_tac I="λit σ. s3.α σ = it ∩ s2.α s2 ∧ s3.invar σ"
in s1.iterate_rule_insert_P)
apply (simp_all add: I s3.empty_correct s3.ins_dj_correct s2.memb_correct)
done
thus "s3.α (g_inter s1 s2) = s1.α s1 ∩ s2.α s2"
and "s3.invar (g_inter s1 s2)" by auto
qed
end
sublocale g_set_xxx_loc
< set_inter s1.α s1.invar s2.α s2.invar s3.α s3.invar g_inter
by (rule g_inter_impl)
locale g_set_xy_defs_loc =
s1: StdSet ops1 + s2: StdSet ops2
for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
definition "g_image_filter f s ≡
s1.iterate s
(λx res. case f x of Some v ⇒ s2.ins v res | _ ⇒ res)
(s2.empty ())"
definition "g_image f s ≡
s1.iterate s (λx res. s2.ins (f x) res) (s2.empty ())"
definition "g_inj_image_filter f s ≡
s1.iterate s
(λx res. case f x of Some v ⇒ s2.ins_dj v res | _ ⇒ res)
(s2.empty ())"
definition "g_inj_image f s ≡
s1.iterate s (λx res. s2.ins_dj (f x) res) (s2.empty ())"
end
locale g_set_xy_loc = g_set_xy_defs_loc ops1 ops2 +
s1: StdSet ops1 + s2: StdSet ops2
for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
lemma g_image_filter_impl:
"set_image_filter s1.α s1.invar s2.α s2.invar g_image_filter"
proof
fix f s
assume I: "s1.invar s"
have A: "g_image_filter f s ==
iterate_to_set s2.empty s2.ins
(set_iterator_image_filter f (s1.iteratei s))"
unfolding g_image_filter_def
iterate_to_set_alt_def set_iterator_image_filter_def
by simp
have ins: "set_ins s2.α s2.invar s2.ins"
and emp: "set_empty s2.α s2.invar s2.empty" by unfold_locales
from iterate_image_filter_to_set_correct[OF ins emp s1.iteratei_correct]
show "s2.α (g_image_filter f s) =
{b. ∃a∈s1.α s. f a = Some b}"
"s2.invar (g_image_filter f s)"
unfolding A using I by auto
qed
lemma g_image_alt: "g_image f s = g_image_filter (Some o f) s"
unfolding g_image_def g_image_filter_def
by auto
lemma g_image_impl: "set_image s1.α s1.invar s2.α s2.invar g_image"
proof -
interpret set_image_filter s1.α s1.invar s2.α s2.invar g_image_filter
by (rule g_image_filter_impl)
show ?thesis
apply unfold_locales
unfolding g_image_alt
by (auto simp add: image_filter_correct)
qed
lemma g_inj_image_filter_impl:
"set_inj_image_filter s1.α s1.invar s2.α s2.invar g_inj_image_filter"
proof
fix f::"'x1 ⇀ 'x2" and s
assume I: "s1.invar s" and INJ: "inj_on f (s1.α s ∩ dom f)"
have A: "g_inj_image_filter f s ==
iterate_to_set s2.empty s2.ins_dj
(set_iterator_image_filter f (s1.iteratei s))"
unfolding g_inj_image_filter_def
iterate_to_set_alt_def set_iterator_image_filter_def
by simp
have ins_dj: "set_ins_dj s2.α s2.invar s2.ins_dj"
and emp: "set_empty s2.α s2.invar s2.empty" by unfold_locales
from set_iterator_image_filter_correct[OF s1.iteratei_correct[OF I] INJ]
have iti_s1_filter: "set_iterator
(set_iterator_image_filter f (s1.iteratei s))
{y. ∃x. x ∈ s1.α s ∧ f x = Some y}"
by simp
from iterate_to_set_correct[OF ins_dj emp, OF iti_s1_filter]
show "s2.α (g_inj_image_filter f s) =
{b. ∃a∈s1.α s. f a = Some b}"
"s2.invar (g_inj_image_filter f s)"
unfolding A by auto
qed
lemma g_inj_image_alt: "g_inj_image f s = g_inj_image_filter (Some o f) s"
unfolding g_inj_image_def g_inj_image_filter_def
by auto
lemma g_inj_image_impl:
"set_inj_image s1.α s1.invar s2.α s2.invar g_inj_image"
proof -
interpret set_inj_image_filter
s1.α s1.invar s2.α s2.invar g_inj_image_filter
by (rule g_inj_image_filter_impl)
have AUX: "⋀S f. inj_on f S ⟹ inj_on (Some ∘ f) (S ∩ dom (Some ∘ f))"
by (auto intro!: inj_onI dest: inj_onD)
show ?thesis
apply unfold_locales
unfolding g_inj_image_alt
by (auto simp add: inj_image_filter_correct AUX)
qed
end
sublocale g_set_xy_loc < set_image_filter s1.α s1.invar s2.α s2.invar
g_image_filter by (rule g_image_filter_impl)
sublocale g_set_xy_loc < set_image s1.α s1.invar s2.α s2.invar
g_image by (rule g_image_impl)
sublocale g_set_xy_loc < set_inj_image s1.α s1.invar s2.α s2.invar
g_inj_image by (rule g_inj_image_impl)
locale g_set_xyy_defs_loc =
s0: StdSetDefs ops0 +
g_set_xx_defs_loc ops1 ops2
for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
and ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
definition g_Union_image
:: "('x0 ⇒ 's1) ⇒ 's0 ⇒ 's2"
where "g_Union_image f S
== s0.iterate S (λx res. g_union (f x) res) (s2.empty ())"
end
locale g_set_xyy_loc = g_set_xyy_defs_loc ops0 ops1 ops2 +
s0: StdSet ops0 +
g_set_xx_loc ops1 ops2
for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
and ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
lemma g_Union_image_impl:
"set_Union_image s0.α s0.invar s1.α s1.invar s2.α s2.invar g_Union_image"
proof -
{
fix s f
have "⟦s0.invar s; ⋀x. x ∈ s0.α s ⟹ s1.invar (f x)⟧ ⟹
s2.α (g_Union_image f s) = ⋃(s1.α ` f ` s0.α s)
∧ s2.invar (g_Union_image f s)"
apply (unfold g_Union_image_def)
apply (rule_tac I="λit res. s2.invar res
∧ s2.α res = ⋃(s1.α`f`(s0.α s - it))" in s0.iterate_rule_P)
apply (fastforce simp add: s2.empty_correct union_correct)+
done
}
thus ?thesis
apply unfold_locales
apply auto
done
qed
end
sublocale g_set_xyy_loc <
set_Union_image s0.α s0.invar s1.α s1.invar s2.α s2.invar g_Union_image
by (rule g_Union_image_impl)
subsection ‹Default Set Operations›
record ('x,'s) set_basic_ops =
bset_op_α :: "'s ⇒ 'x set"
bset_op_invar :: "'s ⇒ bool"
bset_op_empty :: "unit ⇒ 's"
bset_op_memb :: "'x ⇒ 's ⇒ bool"
bset_op_ins :: "'x ⇒ 's ⇒ 's"
bset_op_ins_dj :: "'x ⇒ 's ⇒ 's"
bset_op_delete :: "'x ⇒ 's ⇒ 's"
bset_op_list_it :: "('x,'s) set_list_it"
record ('x,'s) oset_basic_ops = "('x::linorder,'s) set_basic_ops" +
bset_op_ordered_list_it :: "'s ⇒ ('x,'x list) set_iterator"
bset_op_rev_list_it :: "'s ⇒ ('x,'x list) set_iterator"
locale StdBasicSetDefs =
poly_set_iteratei_defs "bset_op_list_it ops"
for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin
abbreviation α where "α == bset_op_α ops"
abbreviation invar where "invar == bset_op_invar ops"
abbreviation empty where "empty == bset_op_empty ops"
abbreviation memb where "memb == bset_op_memb ops"
abbreviation ins where "ins == bset_op_ins ops"
abbreviation ins_dj where "ins_dj == bset_op_ins_dj ops"
abbreviation delete where "delete == bset_op_delete ops"
abbreviation list_it where "list_it ≡ bset_op_list_it ops"
end
locale StdBasicOSetDefs = StdBasicSetDefs ops
+ poly_set_iterateoi_defs "bset_op_ordered_list_it ops"
+ poly_set_rev_iterateoi_defs "bset_op_rev_list_it ops"
for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
abbreviation "ordered_list_it ≡ bset_op_ordered_list_it ops"
abbreviation "rev_list_it ≡ bset_op_rev_list_it ops"
end
locale StdBasicSet = StdBasicSetDefs ops +
set α invar +
set_empty α invar empty +
set_memb α invar memb +
set_ins α invar ins +
set_ins_dj α invar ins_dj +
set_delete α invar delete +
poly_set_iteratei α invar list_it
for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin
lemmas correct[simp] =
empty_correct
memb_correct
ins_correct
ins_dj_correct
delete_correct
end
locale StdBasicOSet =
StdBasicOSetDefs ops +
StdBasicSet ops +
poly_set_iterateoi α invar ordered_list_it +
poly_set_rev_iterateoi α invar rev_list_it
for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
end
context StdBasicSetDefs
begin
definition "g_sng x ≡ ins x (empty ())"
definition "g_isEmpty s ≡ iteratei s (λc. c) (λ_ _. False) True"
definition "g_sel' s P ≡ iteratei s ((=) None)
(λx _. if P x then Some x else None) None"
definition "g_ball s P ≡ iteratei s (λc. c) (λx σ. P x) True"
definition "g_bex s P ≡ iteratei s (λc. ¬c) (λx σ. P x) False"
definition "g_size s ≡ iteratei s (λ_. True) (λx n . Suc n) 0"
definition "g_size_abort m s ≡ iteratei s (λσ. σ < m) (λx. Suc) 0"
definition "g_isSng s ≡ (iteratei s (λσ. σ < 2) (λx. Suc) 0 = 1)"
definition "g_union s1 s2 ≡ iterate s1 ins s2"
definition "g_diff s1 s2 ≡ iterate s2 delete s1"
definition "g_subset s1 s2 ≡ g_ball s1 (λx. memb x s2)"
definition "g_equal s1 s2 ≡ g_subset s1 s2 ∧ g_subset s2 s1"
definition "g_to_list s ≡ iterate s (#) []"
fun g_from_list_aux where
"g_from_list_aux accs [] = accs" |
"g_from_list_aux accs (x#l) = g_from_list_aux (ins x accs) l"
definition "g_from_list l == g_from_list_aux (empty ()) l"
definition "g_inter s1 s2 ≡
iterate s1 (λx s. if memb x s2 then ins_dj x s else s)
(empty ())"
definition "g_union_dj s1 s2 ≡ iterate s1 ins_dj s2"
definition "g_filter P s ≡ iterate s
(λx σ. if P x then ins_dj x σ else σ)
(empty ())"
definition "g_disjoint_witness s1 s2 ≡ g_sel' s1 (λx. memb x s2)"
definition "g_disjoint s1 s2 ≡ g_ball s1 (λx. ¬memb x s2)"
definition dflt_ops
where [icf_rec_def]: "dflt_ops ≡ ⦇
set_op_α = α,
set_op_invar = invar,
set_op_empty = empty,
set_op_memb = memb,
set_op_ins = ins,
set_op_ins_dj = ins_dj,
set_op_delete = delete,
set_op_list_it = list_it,
set_op_sng = g_sng ,
set_op_isEmpty = g_isEmpty ,
set_op_isSng = g_isSng ,
set_op_ball = g_ball ,
set_op_bex = g_bex ,
set_op_size = g_size ,
set_op_size_abort = g_size_abort ,
set_op_union = g_union ,
set_op_union_dj = g_union_dj ,
set_op_diff = g_diff ,
set_op_filter = g_filter ,
set_op_inter = g_inter ,
set_op_subset = g_subset ,
set_op_equal = g_equal ,
set_op_disjoint = g_disjoint ,
set_op_disjoint_witness = g_disjoint_witness ,
set_op_sel = g_sel' ,
set_op_to_list = g_to_list ,
set_op_from_list = g_from_list
⦈"
local_setup ‹Locale_Code.lc_decl_del @{term dflt_ops}›
end
context StdBasicSet
begin
lemma g_sng_impl: "set_sng α invar g_sng"
apply unfold_locales
unfolding g_sng_def
apply (auto simp: ins_correct empty_correct)
done
lemma g_ins_dj_impl: "set_ins_dj α invar ins"
by unfold_locales (auto simp: ins_correct)
lemma g_isEmpty_impl: "set_isEmpty α invar g_isEmpty"
proof
fix s assume I: "invar s"
have A: "g_isEmpty s = iterate_is_empty (iteratei s)"
unfolding g_isEmpty_def iterate_is_empty_def ..
from iterate_is_empty_correct[OF iteratei_correct[OF I]]
show "g_isEmpty s ⟷ α s = {}" unfolding A .
qed
lemma g_sel'_impl: "set_sel' α invar g_sel'"
proof -
have A: "⋀s P. g_sel' s P = iterate_sel_no_map (iteratei s) P"
unfolding g_sel'_def iterate_sel_no_map_alt_def
apply (rule arg_cong[where f="iteratei", THEN cong, THEN cong, THEN cong])
by auto
show ?thesis
unfolding set_sel'_def A
using iterate_sel_no_map_correct[OF iteratei_correct]
apply (simp add: Bex_def Ball_def)
apply (metis option.exhaust)
done
qed
lemma g_ball_alt: "g_ball s P = iterate_ball (iteratei s) P"
unfolding g_ball_def iterate_ball_def by (simp add: id_def)
lemma g_bex_alt: "g_bex s P = iterate_bex (iteratei s) P"
unfolding g_bex_def iterate_bex_def ..
lemma g_ball_impl: "set_ball α invar g_ball"
apply unfold_locales
unfolding g_ball_alt
apply (rule iterate_ball_correct)
by (rule iteratei_correct)
lemma g_bex_impl: "set_bex α invar g_bex"
apply unfold_locales
unfolding g_bex_alt
apply (rule iterate_bex_correct)
by (rule iteratei_correct)
lemma g_size_alt: "g_size s = iterate_size (iteratei s)"
unfolding g_size_def iterate_size_def ..
lemma g_size_abort_alt: "g_size_abort m s = iterate_size_abort (iteratei s) m"
unfolding g_size_abort_def iterate_size_abort_def ..
lemma g_size_impl: "set_size α invar g_size"
apply unfold_locales
unfolding g_size_alt
apply (rule conjunct1[OF iterate_size_correct])
by (rule iteratei_correct)
lemma g_size_abort_impl: "set_size_abort α invar g_size_abort"
apply unfold_locales
unfolding g_size_abort_alt
apply (rule conjunct1[OF iterate_size_abort_correct])
by (rule iteratei_correct)
lemma g_isSng_alt: "g_isSng s = iterate_is_sng (iteratei s)"
unfolding g_isSng_def iterate_is_sng_def iterate_size_abort_def ..
lemma g_isSng_impl: "set_isSng α invar g_isSng"
apply unfold_locales
unfolding g_isSng_alt
apply (drule iterate_is_sng_correct[OF iteratei_correct])
apply (simp add: card_Suc_eq)
done
lemma g_union_impl: "set_union α invar α invar α invar g_union"
unfolding g_union_def[abs_def]
apply unfold_locales
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∪ α s2"
in iterate_rule_insert_P, simp_all)+
done
lemma g_diff_impl: "set_diff α invar α invar g_diff"
unfolding g_diff_def[abs_def]
apply (unfold_locales)
apply (rule_tac I="λit σ. invar σ ∧ α σ = α s1 - it"
in iterate_rule_insert_P, auto)+
done
lemma g_subset_impl: "set_subset α invar α invar g_subset"
proof -
interpret set_ball α invar g_ball by (rule g_ball_impl)
show ?thesis
apply unfold_locales
unfolding g_subset_def
by (auto simp add: ball_correct memb_correct)
qed
lemma g_equal_impl: "set_equal α invar α invar g_equal"
proof -
interpret set_subset α invar α invar g_subset by (rule g_subset_impl)
show ?thesis
apply unfold_locales
unfolding g_equal_def
by (auto simp add: subset_correct)
qed
lemma g_to_list_impl: "set_to_list α invar g_to_list"
proof
fix s
assume I: "invar s"
have A: "g_to_list s = iterate_to_list (iteratei s)"
unfolding g_to_list_def iterate_to_list_def ..
from iterate_to_list_correct [OF iteratei_correct[OF I]]
show "set (g_to_list s) = α s" and "distinct (g_to_list s)"
unfolding A
by auto
qed
lemma g_from_list_impl: "list_to_set α invar g_from_list"
proof -
{
fix l accs
have "invar accs ⟹ α (g_from_list_aux accs l) = set l ∪ α accs
∧ invar (g_from_list_aux accs l)"
by (induct l arbitrary: accs)
(auto simp add: ins_correct)
} thus ?thesis
apply (unfold_locales)
apply (unfold g_from_list_def)
apply (auto simp add: empty_correct)
done
qed
lemma g_inter_impl: "set_inter α invar α invar α invar g_inter"
unfolding g_inter_def[abs_def]
apply unfold_locales
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∩ α s2"
in iterate_rule_insert_P, auto) []
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∩ α s2"
in iterate_rule_insert_P, auto)
done
lemma g_union_dj_impl: "set_union_dj α invar α invar α invar g_union_dj"
unfolding g_union_dj_def[abs_def]
apply unfold_locales
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∪ α s2"
in iterate_rule_insert_P)
apply simp
apply simp
apply (subgoal_tac "x∉α σ")
apply simp
apply blast
apply simp
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∪ α s2"
in iterate_rule_insert_P)
apply simp
apply simp
apply (subgoal_tac "x∉α σ")
apply simp
apply blast
apply simp
done
lemma g_filter_impl: "set_filter α invar α invar g_filter"
unfolding g_filter_def[abs_def]
apply (unfold_locales)
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∩ Collect P"
in iterate_rule_insert_P, auto)
apply (rule_tac I="λit σ. invar σ ∧ α σ = it ∩ Collect P"
in iterate_rule_insert_P, auto)
done
lemma g_disjoint_witness_impl: "set_disjoint_witness
α invar α invar g_disjoint_witness"
proof -
interpret set_sel' α invar g_sel' by (rule g_sel'_impl)
show ?thesis
unfolding g_disjoint_witness_def[abs_def]
apply unfold_locales
by (auto dest: sel'_noneD sel'_someD simp: memb_correct)
qed
lemma g_disjoint_impl: "set_disjoint
α invar α invar g_disjoint"
proof -
interpret set_ball α invar g_ball by (rule g_ball_impl)
show ?thesis
apply unfold_locales
unfolding g_disjoint_def
by (auto simp: memb_correct ball_correct)
qed
end
context StdBasicSet
begin
lemma dflt_ops_impl: "StdSet dflt_ops"
apply (rule StdSet_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (rule g_sng_impl g_isEmpty_impl g_isSng_impl g_ball_impl
g_bex_impl g_size_impl g_size_abort_impl g_union_impl g_union_dj_impl
g_diff_impl g_filter_impl g_inter_impl
g_subset_impl g_equal_impl g_disjoint_impl
g_disjoint_witness_impl g_sel'_impl g_to_list_impl
g_from_list_impl
)+
done
end
context StdBasicOSetDefs
begin
definition "g_min s P ≡ iterateoi s (λx. x = None)
(λx _. if P x then Some x else None) None"
definition "g_max s P ≡ rev_iterateoi s (λx. x = None)
(λx _. if P x then Some x else None) None"
definition "g_to_sorted_list s ≡ rev_iterateo s (#) []"
definition "g_to_rev_list s ≡ iterateo s (#) []"
definition dflt_oops :: "('x::linorder,'s) oset_ops"
where [icf_rec_def]:
"dflt_oops ≡ set_ops.extend
dflt_ops
⦇
set_op_ordered_list_it = ordered_list_it,
set_op_rev_list_it = rev_list_it,
set_op_min = g_min,
set_op_max = g_max,
set_op_to_sorted_list = g_to_sorted_list,
set_op_to_rev_list = g_to_rev_list
⦈"
local_setup ‹Locale_Code.lc_decl_del @{term dflt_oops}›
end
context StdBasicOSet
begin
lemma g_min_impl: "set_min α invar g_min"
proof
fix s P
assume I: "invar s"
from iterateoi_correct[OF I]
have iti': "set_iterator_linord (iterateoi s) (α s)" by simp
note sel_correct = iterate_sel_no_map_linord_correct[OF iti', of P]
have A: "g_min s P = iterate_sel_no_map (iterateoi s) P"
unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp
{ fix x
assume "x∈α s" "P x"
with sel_correct
show "g_min s P ∈ Some ` {x∈α s. P x}" and "the (g_min s P) ≤ x"
unfolding A by auto
}
{ assume "{x∈α s. P x} = {}"
with sel_correct show "g_min s P = None"
unfolding A by auto
}
qed
lemma g_max_impl: "set_max α invar g_max"
proof
fix s P
assume I: "invar s"
from rev_iterateoi_correct[OF I]
have iti': "set_iterator_rev_linord (rev_iterateoi s) (α s)" by simp
note sel_correct = iterate_sel_no_map_rev_linord_correct[OF iti', of P]
have A: "g_max s P = iterate_sel_no_map (rev_iterateoi s) P"
unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp
{ fix x
assume "x∈α s" "P x"
with sel_correct
show "g_max s P ∈ Some ` {x∈α s. P x}" and "the (g_max s P) ≥ x"
unfolding A by auto
}
{ assume "{x∈α s. P x} = {}"
with sel_correct show "g_max s P = None"
unfolding A by auto
}
qed
lemma g_to_sorted_list_impl: "set_to_sorted_list α invar g_to_sorted_list"
proof
fix s
assume I: "invar s"
note iti = rev_iterateoi_correct[OF I]
from iterate_to_list_rev_linord_correct[OF iti]
show "sorted (g_to_sorted_list s)"
"distinct (g_to_sorted_list s)"
"set (g_to_sorted_list s) = α s"
unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
qed
lemma g_to_rev_list_impl: "set_to_rev_list α invar g_to_rev_list"
proof
fix s
assume I: "invar s"
note iti = iterateoi_correct[OF I]
from iterate_to_list_linord_correct[OF iti]
show "sorted (rev (g_to_rev_list s))"
"distinct (g_to_rev_list s)"
"set (g_to_rev_list s) = α s"
unfolding g_to_rev_list_def iterate_to_list_def
by (simp_all)
qed
lemma dflt_oops_impl: "StdOSet dflt_oops"
proof -
interpret aux: StdSet dflt_ops by (rule dflt_ops_impl)
show ?thesis
apply (rule StdOSet_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (rule g_min_impl)
apply (rule g_max_impl)
apply (rule g_to_sorted_list_impl)
apply (rule g_to_rev_list_impl)
done
qed
end
subsection "More Generic Set Algorithms"
text ‹
These algorithms do not have a function specification in a locale, but
their specification is done ad-hoc in the correctness lemma.
›
subsubsection "Image and Filter of Cartesian Product"
locale image_filter_cp_defs_loc =
s1: StdSetDefs ops1 +
s2: StdSetDefs ops2 +
s3: StdSetDefs ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('y,'s2,'more2) set_ops_scheme"
and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin
definition "image_filter_cartesian_product f s1 s2 ==
s1.iterate s1 (λx res.
s2.iterate s2 (λy res.
case (f (x, y)) of
None ⇒ res
| Some z ⇒ (s3.ins z res)
) res
) (s3.empty ())"
lemma image_filter_cartesian_product_alt:
"image_filter_cartesian_product f s1 s2 ==
iterate_to_set s3.empty s3.ins (set_iterator_image_filter f (
set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2)))"
unfolding image_filter_cartesian_product_def iterate_to_set_alt_def
set_iterator_image_filter_def set_iterator_product_def
by simp
definition image_filter_cp where
"image_filter_cp f P s1 s2 ≡
image_filter_cartesian_product
(λxy. if P xy then Some (f xy) else None) s1 s2"
end
locale image_filter_cp_loc = image_filter_cp_defs_loc ops1 ops2 ops3 +
s1: StdSet ops1 +
s2: StdSet ops2 +
s3: StdSet ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('y,'s2,'more2) set_ops_scheme"
and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin
lemma image_filter_cartesian_product_correct:
fixes f :: "'x × 'y ⇀ 'z"
assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
shows "s3.α (image_filter_cartesian_product f s1 s2)
= { z | x y z. f (x,y) = Some z ∧ x∈s1.α s1 ∧ y∈s2.α s2 }" (is ?T1)
"s3.invar (image_filter_cartesian_product f s1 s2)" (is ?T2)
proof -
from set_iterator_product_correct
[OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
have it_s12: "set_iterator
(set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2))
(s1.α s1 × s2.α s2)"
by simp
have LIS:
"set_ins s3.α s3.invar s3.ins"
"set_empty s3.α s3.invar s3.empty"
by unfold_locales
from iterate_image_filter_to_set_correct[OF LIS it_s12, of f]
show ?T1 ?T2
unfolding image_filter_cartesian_product_alt by auto
qed
lemma image_filter_cp_correct:
assumes I: "s1.invar s1" "s2.invar s2"
shows
"s3.α (image_filter_cp f P s1 s2)
= { f (x, y) | x y. P (x, y) ∧ x∈s1.α s1 ∧ y∈s2.α s2 }" (is ?T1)
"s3.invar (image_filter_cp f P s1 s2)" (is ?T2)
proof -
from image_filter_cartesian_product_correct [OF I]
show "?T1" "?T2"
unfolding image_filter_cp_def
by auto
qed
end
locale inj_image_filter_cp_defs_loc =
s1: StdSetDefs ops1 +
s2: StdSetDefs ops2 +
s3: StdSetDefs ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('y,'s2,'more2) set_ops_scheme"
and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin
definition "inj_image_filter_cartesian_product f s1 s2 ==
s1.iterate s1 (λx res.
s2.iterate s2 (λy res.
case (f (x, y)) of
None ⇒ res
| Some z ⇒ (s3.ins_dj z res)
) res
) (s3.empty ())"
lemma inj_image_filter_cartesian_product_alt:
"inj_image_filter_cartesian_product f s1 s2 ==
iterate_to_set s3.empty s3.ins_dj (set_iterator_image_filter f (
set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2)))"
unfolding inj_image_filter_cartesian_product_def iterate_to_set_alt_def
set_iterator_image_filter_def set_iterator_product_def
by simp
definition inj_image_filter_cp where
"inj_image_filter_cp f P s1 s2 ≡
inj_image_filter_cartesian_product
(λxy. if P xy then Some (f xy) else None) s1 s2"
end
locale inj_image_filter_cp_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3 +
s1: StdSet ops1 +
s2: StdSet ops2 +
s3: StdSet ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('y,'s2,'more2) set_ops_scheme"
and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin
lemma inj_image_filter_cartesian_product_correct:
fixes f :: "'x × 'y ⇀ 'z"
assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
assumes INJ: "inj_on f (s1.α s1 × s2.α s2 ∩ dom f)"
shows "s3.α (inj_image_filter_cartesian_product f s1 s2)
= { z | x y z. f (x,y) = Some z ∧ x∈s1.α s1 ∧ y∈s2.α s2 }" (is ?T1)
"s3.invar (inj_image_filter_cartesian_product f s1 s2)" (is ?T2)
proof -
from set_iterator_product_correct
[OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
have it_s12: "set_iterator
(set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2))
(s1.α s1 × s2.α s2)"
by simp
have LIS:
"set_ins_dj s3.α s3.invar s3.ins_dj"
"set_empty s3.α s3.invar s3.empty"
by unfold_locales
from iterate_inj_image_filter_to_set_correct[OF LIS it_s12 INJ]
show ?T1 ?T2
unfolding inj_image_filter_cartesian_product_alt by auto
qed
lemma inj_image_filter_cp_correct:
assumes I: "s1.invar s1" "s2.invar s2"
assumes INJ: "inj_on f {x∈s1.α s1 × s2.α s2. P x}"
shows
"s3.α (inj_image_filter_cp f P s1 s2)
= { f (x, y) | x y. P (x, y) ∧ x∈s1.α s1 ∧ y∈s2.α s2 }" (is ?T1)
"s3.invar (inj_image_filter_cp f P s1 s2)" (is ?T2)
proof -
let ?f = "λxy. if P xy then Some (f xy) else None"
from INJ have INJ': "inj_on ?f (s1.α s1 × s2.α s2 ∩ dom ?f)"
by (force intro!: inj_onI dest: inj_onD split: if_split_asm)
from inj_image_filter_cartesian_product_correct [OF I INJ']
show "?T1" "?T2"
unfolding inj_image_filter_cp_def
by auto
qed
end
subsubsection "Cartesian Product"
locale cart_defs_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('y,'s2,'more2) set_ops_scheme"
and ops3 :: "('x×'y,'s3,'more3) set_ops_scheme"
begin
definition "cart s1 s2 ≡
s1.iterate s1
(λx. s2.iterate s2 (λy res. s3.ins_dj (x,y) res))
(s3.empty ())"
lemma cart_alt: "cart s1 s2 ==
inj_image_filter_cartesian_product Some s1 s2"
unfolding cart_def inj_image_filter_cartesian_product_def
by simp
end
locale cart_loc = cart_defs_loc ops1 ops2 ops3
+ inj_image_filter_cp_loc ops1 ops2 ops3
for ops1 :: "('x,'s1,'more1) set_ops_scheme"
and ops2 :: "('y,'s2,'more2) set_ops_scheme"
and ops3 :: "('x×'y,'s3,'more3) set_ops_scheme"
begin
lemma cart_correct:
assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
shows "s3.α (cart s1 s2)
= s1.α s1 × s2.α s2" (is ?T1)
"s3.invar (cart s1 s2)" (is ?T2)
unfolding cart_alt
by (auto simp add:
inj_image_filter_cartesian_product_correct[OF I, where f=Some])
end
subsection ‹Generic Algorithms outside basic-set›
text ‹
In this section, we present some generic algorithms that are not
formulated in terms of basic-set. They are useful for setting up
some data structures.
›
subsection ‹Image (by image-filter)›
definition "iflt_image iflt f s == iflt (λx. Some (f x)) s"
lemma iflt_image_correct:
assumes "set_image_filter α1 invar1 α2 invar2 iflt"
shows "set_image α1 invar1 α2 invar2 (iflt_image iflt)"
proof -
interpret set_image_filter α1 invar1 α2 invar2 iflt by fact
show ?thesis
apply (unfold_locales)
apply (unfold iflt_image_def)
apply (auto simp add: image_filter_correct)
done
qed
subsection‹Injective Image-Filter (by image-filter)›
definition [code_unfold]: "iflt_inj_image = iflt_image"
lemma iflt_inj_image_correct:
assumes "set_inj_image_filter α1 invar1 α2 invar2 iflt"
shows "set_inj_image α1 invar1 α2 invar2 (iflt_inj_image iflt)"
proof -
interpret set_inj_image_filter α1 invar1 α2 invar2 iflt by fact
show ?thesis
apply (unfold_locales)
apply (unfold iflt_image_def iflt_inj_image_def)
apply (subst inj_image_filter_correct)
apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
apply (subst inj_image_filter_correct)
apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
done
qed
subsection‹Filter (by image-filter)›
definition "iflt_filter iflt P s == iflt (λx. if P x then Some x else None) s"
lemma iflt_filter_correct:
fixes α1 :: "'s1 ⇒ 'a set"
fixes α2 :: "'s2 ⇒ 'a set"
assumes "set_inj_image_filter α1 invar1 α2 invar2 iflt"
shows "set_filter α1 invar1 α2 invar2 (iflt_filter iflt)"
proof (rule set_filter.intro)
fix s P
assume invar_s: "invar1 s"
interpret S: set_inj_image_filter α1 invar1 α2 invar2 iflt by fact
let ?f' = "λx::'a. if P x then Some x else None"
have inj_f': "inj_on ?f' (α1 s ∩ dom ?f')"
by (simp add: inj_on_def Ball_def domIff)
note correct' = S.inj_image_filter_correct [OF invar_s inj_f',
folded iflt_filter_def]
show "invar2 (iflt_filter iflt P s)"
"α2 (iflt_filter iflt P s) = {e ∈ α1 s. P e}"
by (auto simp add: correct')
qed
end
Theory SetByMap
section ‹\isaheader{Implementing Sets by Maps}›
theory SetByMap
imports
"../spec/SetSpec"
"../spec/MapSpec"
SetGA
MapGA
begin
text_raw ‹\label{thy:SetByMap}›
text ‹
In this theory, we show how to implement sets
by maps.
›
text ‹Auxiliary lemma›
lemma foldli_foldli_map_eq:
"foldli (foldli l (λx. True) (λx l. l@[f x]) []) c f' σ0
= foldli l c (f' o f) σ0"
proof -
show ?thesis
apply (simp add: map_by_foldl foldli_map foldli_foldl)
done
qed
locale SetByMapDefs =
map: StdBasicMapDefs ops
for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
definition "α s ≡ dom (map.α s)"
definition "invar s ≡ map.invar s"
definition empty where "empty ≡ map.empty"
definition "memb x s ≡ map.lookup x s ≠ None"
definition "ins x s ≡ map.update x () s"
definition "ins_dj x s ≡ map.update_dj x () s"
definition "delete x s ≡ map.delete x s"
definition list_it :: "'s ⇒ ('x,'x list) set_iterator"
where "list_it s c f σ0 ≡ it_to_it (map.list_it s) c (f o fst) σ0"
local_setup ‹Locale_Code.lc_decl_del @{term list_it}›
lemma list_it_alt: "list_it s = map_iterator_dom (map.iteratei s)"
proof -
have A: "⋀f. (λ(x,_). f x) = (λx. f (fst x))" by auto
show ?thesis
unfolding list_it_def[abs_def] map_iterator_dom_def
poly_map_iteratei_defs.iteratei_def
set_iterator_image_def set_iterator_image_filter_def
by (auto simp: comp_def)
qed
lemma list_it_unfold:
"it_to_it (list_it s) c f σ0 = map.iteratei s c (f o fst) σ0"
unfolding list_it_def[abs_def] it_to_it_def
unfolding poly_map_iteratei_defs.iteratei_def it_to_it_def
by (simp add: foldli_foldli_map_eq comp_def)
definition [icf_rec_def]: "dflt_basic_ops ≡ ⦇
bset_op_α = α,
bset_op_invar = invar,
bset_op_empty = empty,
bset_op_memb = memb,
bset_op_ins = ins,
bset_op_ins_dj = ins_dj,
bset_op_delete = delete,
bset_op_list_it = list_it
⦈"
local_setup ‹Locale_Code.lc_decl_del @{term dflt_basic_ops}›
end
setup ‹
(Record_Intf.add_unf_thms_global @{thms
SetByMapDefs.list_it_def[abs_def]
})
›
locale SetByMap = SetByMapDefs ops +
map: StdBasicMap ops
for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
lemma empty_impl: "set_empty α invar empty"
apply unfold_locales
unfolding α_def invar_def empty_def
by (auto simp: map.empty_correct)
lemma memb_impl: "set_memb α invar memb"
apply unfold_locales
unfolding α_def invar_def memb_def
by (auto simp: map.lookup_correct)
lemma ins_impl: "set_ins α invar ins"
apply unfold_locales
unfolding α_def invar_def ins_def
by (auto simp: map.update_correct)
lemma ins_dj_impl: "set_ins_dj α invar ins_dj"
apply unfold_locales
unfolding α_def invar_def ins_dj_def
by (auto simp: map.update_dj_correct)
lemma delete_impl: "set_delete α invar delete"
apply unfold_locales
unfolding α_def invar_def delete_def
by (auto simp: map.delete_correct)
lemma list_it_impl: "poly_set_iteratei α invar list_it"
proof
fix s
assume I: "invar s"
hence I': "map.invar s" unfolding invar_def .
have S: "⋀f. (λ(x,_). f x) = (λxy. f (fst xy))"
by auto
from map_iterator_dom_correct[OF map.iteratei_correct[OF I']]
show "set_iterator (list_it s) (α s)"
unfolding α_def list_it_alt .
show "finite (α s)"
unfolding α_def by (simp add: map.finite[OF I'])
qed
lemma dflt_basic_ops_impl: "StdBasicSet dflt_basic_ops"
apply (rule StdBasicSet.intro)
apply (simp_all add: icf_rec_unf)
apply (rule empty_impl memb_impl ins_impl
ins_dj_impl delete_impl
list_it_impl[unfolded SetByMapDefs.list_it_def[abs_def]]
)+
done
end
locale OSetByOMapDefs = SetByMapDefs ops +
map: StdBasicOMapDefs ops
for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
definition ordered_list_it :: "'s ⇒ ('x,'x list) set_iterator"
where "ordered_list_it s c f σ0
≡ it_to_it (map.ordered_list_it s) c (f o fst) σ0"
local_setup ‹Locale_Code.lc_decl_del @{term ordered_list_it}›
definition rev_list_it :: "'s ⇒ ('x,'x list) set_iterator"
where "rev_list_it s c f σ0 ≡ it_to_it (map.rev_list_it s) c (f o fst) σ0"
local_setup ‹Locale_Code.lc_decl_del @{term rev_list_it}›
definition [icf_rec_def]: "dflt_basic_oops ≡
set_basic_ops.extend dflt_basic_ops ⦇
bset_op_ordered_list_it = ordered_list_it,
bset_op_rev_list_it = rev_list_it
⦈"
local_setup ‹Locale_Code.lc_decl_del @{term dflt_basic_oops}›
end
setup ‹
(Record_Intf.add_unf_thms_global @{thms
OSetByOMapDefs.ordered_list_it_def[abs_def]
OSetByOMapDefs.rev_list_it_def[abs_def]
})
›
locale OSetByOMap = OSetByOMapDefs ops +
SetByMap ops + map: StdBasicOMap ops
for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
lemma ordered_list_it_impl: "poly_set_iterateoi α invar ordered_list_it"
proof
fix s
assume I: "invar s"
hence I': "map.invar s" unfolding invar_def .
have S: "⋀f. (λ(x,_). f x) = (λxy. f (fst xy))"
by auto
have A: "⋀s. ordered_list_it s = map_iterator_dom (map.iterateoi s)"
unfolding ordered_list_it_def[abs_def]
map_iterator_dom_def set_iterator_image_alt_def map.iterateoi_def
by (simp add: S comp_def)
from map_iterator_linord_dom_correct[OF map.iterateoi_correct[OF I']]
show "set_iterator_linord (ordered_list_it s) (α s)"
unfolding α_def A .
show "finite (α s)"
unfolding α_def by (simp add: map.finite[OF I'])
qed
lemma rev_list_it_impl: "poly_set_rev_iterateoi α invar rev_list_it"
proof
fix s
assume I: "invar s"
hence I': "map.invar s" unfolding invar_def .
have S: "⋀f. (λ(x,_). f x) = (λxy. f (fst xy))"
by auto
have A: "⋀s. rev_list_it s = map_iterator_dom (map.rev_iterateoi s)"
unfolding rev_list_it_def[abs_def]
map_iterator_dom_def set_iterator_image_alt_def map.rev_iterateoi_def
by (simp add: S comp_def)
from map_iterator_rev_linord_dom_correct[
OF map.rev_iterateoi_correct[OF I']]
show "set_iterator_rev_linord (rev_list_it s) (α s)"
unfolding α_def A .
show "finite (α s)"
unfolding α_def by (simp add: map.finite[OF I'])
qed
lemma dflt_basic_oops_impl: "StdBasicOSet dflt_basic_oops"
proof -
interpret aux: StdBasicSet dflt_basic_ops by (rule dflt_basic_ops_impl)
show ?thesis
apply (rule StdBasicOSet.intro)
apply (rule StdBasicSet.intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (rule
ordered_list_it_impl[unfolded ordered_list_it_def[abs_def]]
rev_list_it_impl[unfolded rev_list_it_def[abs_def]]
)+
done
qed
end
sublocale SetByMap < basic: StdBasicSet "dflt_basic_ops"
by (rule dflt_basic_ops_impl)
sublocale OSetByOMap < obasic: StdBasicOSet "dflt_basic_oops"
by (rule dflt_basic_oops_impl)
lemma proper_it'_map2set: "proper_it' it it'
⟹ proper_it' (λs c f. it s c (f o fst)) (λs c f. it' s c (f o fst))"
unfolding proper_it'_def
apply clarsimp
apply (drule_tac x=s in spec)
apply (erule proper_itE)
apply (rule proper_itI)
apply (auto simp add: foldli_map[symmetric] intro!: ext)
done
end
Theory ListGA
section ‹\isaheader{Generic Algorithms for Sequences}›
theory ListGA
imports "../spec/ListSpec"
begin
subsection ‹Iterators›
subsubsection ‹iteratei (by get, size)›
locale idx_iteratei_loc =
list_size + list_get +
constrains α :: "'s ⇒ 'a list"
assumes [simp]: "⋀s. invar s"
begin
fun idx_iteratei_aux
:: "nat ⇒ nat ⇒ 's ⇒ ('σ⇒bool) ⇒ ('a ⇒'σ ⇒ 'σ) ⇒ 'σ ⇒ 'σ"
where
"idx_iteratei_aux sz i l c f σ = (
if i=0 ∨ ¬ c σ then σ
else idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) σ)
)"
declare idx_iteratei_aux.simps[simp del]
lemma idx_iteratei_aux_simps[simp]:
"i=0 ⟹ idx_iteratei_aux sz i l c f σ = σ"
"¬c σ ⟹ idx_iteratei_aux sz i l c f σ = σ"
"⟦i≠0; c σ⟧ ⟹ idx_iteratei_aux sz i l c f σ = idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) σ)"
apply -
apply (subst idx_iteratei_aux.simps, simp)+
done
definition idx_iteratei where
"idx_iteratei l c f σ ≡ idx_iteratei_aux (size l) (size l) l c f σ"
lemma idx_iteratei_correct:
shows "idx_iteratei s = foldli (α s)"
proof -
{
fix n l
assume A: "Suc n ≤ length l"
hence B: "length l - Suc n < length l" by simp
from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
from Cons_nth_drop_Suc[OF B, simplified] have
"drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l"
by simp
} note drop_aux=this
{
fix s c f σ i
assume "invar s" "i≤size s"
hence "idx_iteratei_aux (size s) i s c f σ
= foldli (drop (size s - i) (α s)) c f σ"
proof (induct i arbitrary: σ)
case 0 with size_correct[of s] show ?case by simp
next
case (Suc n)
note [simp, intro!] = Suc.prems(1)
show ?case proof (cases "c σ")
case False thus ?thesis by simp
next
case [simp, intro!]: True
show ?thesis using Suc by (simp add: get_correct size_correct drop_aux)
qed
qed
} note aux=this
show ?thesis
unfolding idx_iteratei_def[abs_def]
by (auto simp add: fun_eq_iff aux[of _ "size s", simplified])
qed
lemmas idx_iteratei_unfold[code_unfold] = idx_iteratei_correct[symmetric]
subsubsection ‹reverse\_iteratei (by get, size)›
fun idx_reverse_iteratei_aux
:: "nat ⇒ nat ⇒ 's ⇒ ('σ⇒bool) ⇒ ('a ⇒'σ ⇒ 'σ) ⇒ 'σ ⇒ 'σ"
where
"idx_reverse_iteratei_aux sz i l c f σ = (
if i=0 ∨ ¬ c σ then σ
else idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) σ)
)"
declare idx_reverse_iteratei_aux.simps[simp del]
lemma idx_reverse_iteratei_aux_simps[simp]:
"i=0 ⟹ idx_reverse_iteratei_aux sz i l c f σ = σ"
"¬c σ ⟹ idx_reverse_iteratei_aux sz i l c f σ = σ"
"⟦i≠0; c σ⟧ ⟹ idx_reverse_iteratei_aux sz i l c f σ
= idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) σ)"
by (subst idx_reverse_iteratei_aux.simps, simp)+
definition "idx_reverse_iteratei l c f σ
== idx_reverse_iteratei_aux (size l) (size l) l c f σ"
lemma idx_reverse_iteratei_correct:
shows "idx_reverse_iteratei s = foldri (α s)"
proof -
{
fix s c f σ i
assume "invar s" "i≤size s"
hence "idx_reverse_iteratei_aux (size s) i s c f σ
= foldri (take i (α s)) c f σ"
proof (induct i arbitrary: σ)
case 0 with size_correct[of s] show ?case by simp
next
case (Suc n)
note [simp, intro!] = Suc.prems(1)
show ?case proof (cases "c σ")
case False thus ?thesis by simp
next
case [simp, intro!]: True
show ?thesis using Suc
by (simp add: get_correct size_correct take_Suc_conv_app_nth)
qed
qed
} note aux=this
show ?thesis
unfolding idx_reverse_iteratei_def[abs_def]
apply (simp add: fun_eq_iff aux[of _ "size s", simplified])
apply (simp add: size_correct)
done
qed
lemmas idx_reverse_iteratei_unfold[code_unfold]
= idx_reverse_iteratei_correct[symmetric]
end
subsection ‹Size (by iterator)›
locale it_size_loc = poly_list_iteratei +
constrains α :: "'s ⇒ 'a list"
begin
definition it_size :: "'s ⇒ nat"
where "it_size l == iterate l (λx res. Suc res) (0::nat)"
lemma it_size_impl: shows "list_size α invar it_size"
apply (unfold_locales)
apply (unfold it_size_def)
apply (simp add: iterate_correct foldli_foldl)
done
end
subsubsection ‹Size (by reverse\_iterator)›
locale rev_it_size_loc = poly_list_rev_iteratei +
constrains α :: "'s ⇒ 'a list"
begin
definition rev_it_size :: "'s ⇒ nat"
where "rev_it_size l == rev_iterate l (λx res. Suc res) (0::nat)"
lemma rev_it_size_impl:
shows "list_size α invar rev_it_size"
apply (unfold_locales)
apply (unfold rev_it_size_def)
apply (simp add: rev_iterate_correct foldri_foldr)
done
end
subsection ‹Get (by iteratori)›
locale it_get_loc = poly_list_iteratei +
constrains α :: "'s ⇒ 'a list"
begin
definition it_get:: "'s ⇒ nat ⇒ 'a"
where "it_get s i ≡
the (snd (iteratei s
(λ(i,x). x=None)
(λx (i,_). if i=0 then (0,Some x) else (i - 1,None))
(i,None)))"
lemma it_get_correct:
shows "list_get α invar it_get"
proof
fix s i
assume "invar s" "i < length (α s)"
define l where "l = α s"
from ‹i < length (α s)›
show "it_get s i = α s ! i"
unfolding it_get_def iteratei_correct l_def[symmetric]
proof (induct i arbitrary: l)
case 0
then obtain x xs where l_eq[simp]: "l = x # xs" by (cases l, auto)
thus ?case by simp
next
case (Suc i)
note ind_hyp = Suc(1)
note Suc_i_le = Suc(2)
from Suc_i_le obtain x xs
where l_eq[simp]: "l = x # xs" by (cases l, auto)
from ind_hyp [of xs] Suc_i_le
show ?case by simp
qed
qed
end
end
Theory SetIndex
section ‹\isaheader{Indices of Sets}›
theory SetIndex
imports
"../spec/MapSpec"
"../spec/SetSpec"
begin
text_raw ‹\label{thy:SetIndex}›
text ‹
This theory defines an indexing operation that builds an index from a set
and an indexing function.
Here, index is a map from indices to all values of the set with that index.
›
subsection "Indexing by Function"
definition index :: "('a ⇒ 'i) ⇒ 'a set ⇒ 'i ⇒ 'a set"
where "index f s i == { x∈s . f x = i }"
lemma indexI: "⟦ x∈s; f x = i ⟧ ⟹ x∈index f s i" by (unfold index_def) auto
lemma indexD:
"x∈index f s i ⟹ x∈s"
"x∈index f s i ⟹ f x = i"
by (unfold index_def) auto
lemma index_iff[simp]: "x∈index f s i ⟷ x∈s ∧ f x = i" by (simp add: index_def)
subsection "Indexing by Map"
definition index_map :: "('a ⇒ 'i) ⇒ 'a set ⇒ 'i ⇀ 'a set"
where "index_map f s i == let s=index f s i in if s={} then None else Some s"
definition im_α where "im_α im i == case im i of None ⇒ {} | Some s ⇒ s"
lemma index_map_correct: "im_α (index_map f s) = index f s"
apply (rule ext)
apply (unfold index_def index_map_def im_α_def)
apply auto
done
subsection "Indexing by Maps and Sets from the Isabelle Collections Framework"
text ‹
In this theory, we define the generic algorithm as constants outside any locale,
but prove the correctness lemmas inside a locale that assumes correctness of all
prerequisite functions.
Finally, we export the correctness lemmas from the locale.
›
locale index_loc =
m: StdMap m_ops +
s: StdSet s_ops
for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
and s_ops :: "('x,'s,'more2) set_ops_scheme"
begin
definition ci_α' where
"ci_α' ci i == case m.α ci i of None ⇒ None | Some s ⇒ Some (s.α s)"
definition "ci_α == im_α ∘ ci_α'"
definition ci_invar where
"ci_invar ci == m.invar ci ∧ (∀i s. m.α ci i = Some s ⟶ s.invar s)"
lemma ci_impl_minvar: "ci_invar m ⟹ m.invar m" by (unfold ci_invar_def) auto
definition is_index :: "('x ⇒ 'i) ⇒ 'x set ⇒ 'm ⇒ bool"
where
"is_index f s idx == ci_invar idx ∧ ci_α' idx = index_map f s"
lemma is_index_invar: "is_index f s idx ⟹ ci_invar idx"
by (simp add: is_index_def)
lemma is_index_correct: "is_index f s idx ⟹ ci_α idx = index f s"
by (simp only: is_index_def index_map_def ci_α_def)
(simp add: index_map_correct)
definition lookup :: "'i ⇒ 'm ⇒ 's" where
"lookup i m == case m.lookup i m of None ⇒ (s.empty ()) | Some s ⇒ s"
lemma lookup_invar': "ci_invar m ⟹ s.invar (lookup i m)"
apply (unfold ci_invar_def lookup_def)
apply (auto split: option.split simp add: m.lookup_correct s.empty_correct)
done
lemma lookup_correct:
assumes I[simp, intro!]: "is_index f s idx"
shows
"s.α (lookup i idx) = index f s i"
"s.invar (lookup i idx)"
proof goal_cases
case 2 thus ?case using I by (simp add: is_index_def lookup_invar')
next
case 1
have [simp, intro!]: "m.invar idx"
using ci_impl_minvar[OF is_index_invar[OF I]]
by simp
thus ?case
proof (cases "m.lookup i idx")
case None
hence [simp]: "m.α idx i = None" by (simp add: m.lookup_correct)
from is_index_correct[OF I] have "index f s i = ci_α idx i" by simp
also have "… = {}" by (simp add: ci_α_def ci_α'_def im_α_def)
finally show ?thesis by (simp add: lookup_def None s.empty_correct)
next
case (Some si)
hence [simp]: "m.α idx i = Some si" by (simp add: m.lookup_correct)
from is_index_correct[OF I] have "index f s i = ci_α idx i" by simp
also have "… = s.α si" by (simp add: ci_α_def ci_α'_def im_α_def)
finally show ?thesis by (simp add: lookup_def Some s.empty_correct)
qed
qed
end
locale build_index_loc = index_loc m_ops s_ops +
t: StdSet t_ops
for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
and s_ops :: "('x,'s,'more3) set_ops_scheme"
and t_ops :: "('x,'t,'more2) set_ops_scheme"
begin
text "Building indices"
definition idx_build_stepfun :: "('x ⇒ 'i) ⇒ 'x ⇒ 'm ⇒ 'm" where
"idx_build_stepfun f x m ==
let i=f x in
(case m.lookup i m of
None ⇒ m.update i (s.ins x (s.empty ())) m |
Some s ⇒ m.update i (s.ins x s) m
)"
definition idx_build :: "('x ⇒ 'i) ⇒ 't ⇒ 'm" where
"idx_build f t == t.iterate t (idx_build_stepfun f) (m.empty ())"
lemma idx_build_correct:
assumes I: "t.invar t"
shows "ci_α' (idx_build f t) = index_map f (t.α t)" (is ?T1) and
[simp]: "ci_invar (idx_build f t)" (is ?T2)
proof -
have "t.invar t ⟹
ci_α' (idx_build f t) = index_map f (t.α t) ∧ ci_invar (idx_build f t)"
apply (unfold idx_build_def)
apply (rule_tac
I="λit m. ci_α' m = index_map f (t.α t - it) ∧ ci_invar m"
in t.iterate_rule_P)
apply assumption
apply (simp add: ci_invar_def m.empty_correct)
apply (rule ext)
apply (unfold ci_α'_def index_map_def index_def)[1]
apply (simp add: m.empty_correct)
defer
apply simp
apply (rule conjI)
defer
apply (unfold idx_build_stepfun_def)[1]
apply (auto
simp add: ci_invar_def m.update_correct m.lookup_correct
s.empty_correct s.ins_correct Let_def
split: option.split) [1]
apply (rule ext)
proof goal_cases
case prems: (1 x it m i)
hence INV[simp, intro!]: "m.invar m" by (simp add: ci_invar_def)
from prems have
INVS[simp, intro]: "!!q s. m.α m q = Some s ⟹ s.invar s"
by (simp add: ci_invar_def)
show ?case proof (cases "i=f x")
case [simp]: True
show ?thesis proof (cases "m.α m (f x)")
case [simp]: None
hence "idx_build_stepfun f x m = m.update i (s.ins x (s.empty ())) m"
apply (unfold idx_build_stepfun_def)
apply (simp add: m.update_correct m.lookup_correct s.empty_correct)
done
hence "ci_α' (idx_build_stepfun f x m) i = Some {x}"
by (simp add: m.update_correct
s.ins_correct s.empty_correct ci_α'_def)
also {
have "None = ci_α' m (f x)"
by (simp add: ci_α'_def)
also from prems(4) have "… = index_map f (t.α t - it) i" by simp
finally have E: "{xa ∈ t.α t - it. f xa = i} = {}"
by (simp add: index_map_def index_def split: if_split_asm)
moreover have
"{xa ∈ t.α t - (it - {x}). f xa = i}
= {xa ∈ t.α t - it. f xa = i} ∪ {x}"
using prems(2,3) by auto
ultimately have "Some {x} = index_map f (t.α t - (it - {x})) i"
by (unfold index_map_def index_def) auto
} finally show ?thesis .
next
case [simp]: (Some ss)
hence [simp, intro!]: "s.invar ss" by (simp del: Some)
hence "idx_build_stepfun f x m = m.update (f x) (s.ins x ss) m"
by (unfold idx_build_stepfun_def)
(simp add: m.update_correct m.lookup_correct)
hence "ci_α' (idx_build_stepfun f x m) i = Some (insert x (s.α ss))"
by (simp add: m.update_correct s.ins_correct ci_α'_def)
also {
have "Some (s.α ss) = ci_α' m (f x)"
by (simp add: ci_α'_def)
also from prems(4) have "… = index_map f (t.α t - it) i" by simp
finally have E: "{xa ∈ t.α t - it. f xa = i} = s.α ss"
by (simp add: index_map_def index_def split: if_split_asm)
moreover have
"{xa ∈ t.α t - (it - {x}). f xa = i}
= {xa ∈ t.α t - it. f xa = i} ∪ {x}"
using prems(2,3) by auto
ultimately have
"Some (insert x (s.α ss)) = index_map f (t.α t - (it - {x})) i"
by (unfold index_map_def index_def) auto
}
finally show ?thesis .
qed
next
case False hence C: "i≠f x" "f x≠i" by simp_all
have "ci_α' (idx_build_stepfun f x m) i = ci_α' m i"
apply (unfold ci_α'_def idx_build_stepfun_def)
apply (simp
split: option.split_asm option.split
add: Let_def m.lookup_correct m.update_correct
s.ins_correct s.empty_correct C)
done
also from prems(4) have "ci_α' m i = index_map f (t.α t - it) i"
by simp
also have
"{xa ∈ t.α t - (it - {x}). f xa = i} = {xa ∈ t.α t - it. f xa = i}"
using prems(2,3) C by auto
hence "index_map f (t.α t - it) i = index_map f (t.α t - (it-{x})) i"
by (unfold index_map_def index_def) simp
finally show ?thesis .
qed
qed
with I show ?T1 ?T2 by auto
qed
lemma idx_build_is_index:
"t.invar t ⟹ is_index f (t.α t) (idx_build f t)"
by (simp add: idx_build_correct index_map_correct ci_α_def is_index_def)
end
end
Theory Algos
section ‹\isaheader{More Generic Algorithms}›
theory Algos
imports
"../spec/SetSpec"
"../spec/MapSpec"
"../spec/ListSpec"
begin
text_raw ‹\label{thy:Algos}›
subsection "Injective Map to Naturals"
text "Whether a set is an initial segment of the natural numbers"
definition inatseg :: "nat set ⇒ bool"
where "inatseg s == ∃k. s = {i::nat. i<k}"
lemma inatseg_simps[simp]:
"inatseg {}"
"inatseg {0}"
by (unfold inatseg_def)
auto
text "Compute an injective map from objects into an initial
segment of the natural numbers"
locale map_to_nat_loc =
s: StdSet s_ops +
m: StdMap m_ops
for s_ops :: "('x,'s,'more1) set_ops_scheme"
and m_ops :: "('x,nat,'m,'more2) map_ops_scheme"
begin
definition map_to_nat
:: "'s ⇒ 'm" where
"map_to_nat s ==
snd (s.iterate s (λx (c,m). (c+1,m.update x c m)) (0,m.empty ()))"
lemma map_to_nat_correct:
assumes INV[simp]: "s.invar s"
shows
"dom (m.α (map_to_nat s)) = s.α s" (is ?T1) and
[rule_format]: "inj_on (m.α (map_to_nat s)) (s.α s)" (is ?T2) and
[rule_format]: "inatseg (ran (m.α (map_to_nat s)))" (is ?T3) and
"m.invar (map_to_nat s)" (is ?T4)
proof -
have i_aux: "!!m S S' k v. ⟦inj_on m S; S' = insert k S; v∉ran m⟧
⟹ inj_on (m(k↦v)) S'"
apply (rule inj_onI)
apply (simp split: if_split_asm)
apply (simp add: ran_def)
apply (simp add: ran_def)
apply blast
apply (blast dest: inj_onD)
done
have "?T1 ∧ ?T2 ∧ ?T3 ∧ ?T4"
apply (unfold map_to_nat_def)
apply (rule_tac I="λit (c,m).
m.invar m ∧
dom (m.α m) = s.α s - it ∧
inj_on (m.α m) (s.α s - it) ∧
(ran (m.α m) = {i. i<c})
" in s.iterate_rule_P)
apply simp
apply (simp add: m.empty_correct)
apply (case_tac σ)
apply (simp add: m.empty_correct m.update_correct)
apply (intro conjI)
apply blast
apply clarify
apply (rule_tac m2="m.α ba" and
k2=x and v2=aa and
S'2="(s.α s - (it - {x}))" and
S2="(s.α s - it)"
in i_aux)
apply auto [3]
apply auto [1]
apply (case_tac σ)
apply (auto simp add: inatseg_def)
done
thus ?T1 ?T2 ?T3 ?T4 by auto
qed
end
subsection "Map from Set"
text "Build a map using a set of keys and a function to compute the values."
locale it_dom_fun_to_map_loc =
s: StdSet s_ops
+ m: StdMap m_ops
for s_ops :: "('k,'s,'more1) set_ops_scheme"
and m_ops :: "('k,'v,'m,'more2) map_ops_scheme"
begin
definition it_dom_fun_to_map ::
"'s ⇒ ('k ⇒ 'v) ⇒ 'm"
where "it_dom_fun_to_map s f ==
s.iterate s (λk m. m.update_dj k (f k) m) (m.empty ())"
lemma it_dom_fun_to_map_correct:
assumes INV: "s.invar s"
shows "m.α (it_dom_fun_to_map s f) k
= (if k ∈ s.α s then Some (f k) else None)" (is ?G1)
and "m.invar (it_dom_fun_to_map s f)" (is ?G2)
proof -
have "m.α (it_dom_fun_to_map s f) k
= (if k ∈ s.α s then Some (f k) else None) ∧
m.invar (it_dom_fun_to_map s f)"
unfolding it_dom_fun_to_map_def
apply (rule s.iterate_rule_P[where
I = "λit res. m.invar res
∧ (∀k. m.α res k = (if (k ∈ (s.α s) - it) then Some (f k) else None))"
])
apply (simp add: INV)
apply (simp add: m.empty_correct)
apply (subgoal_tac "x∉dom (m.α σ)")
apply (auto simp: INV m.empty_correct m.update_dj_correct) []
apply auto [2]
done
thus ?G1 and ?G2
by auto
qed
end
locale set_to_list_defs_loc =
s: StdSetDefs s_ops
+ l: StdListDefs l_ops
for s_ops :: "('x,'s,'more1) set_ops_scheme"
and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
definition "g_set_to_listl s ≡ s.iterate s l.appendl (l.empty ())"
definition "g_set_to_listr s ≡ s.iterate s l.appendr (l.empty ())"
end
locale set_to_list_loc = set_to_list_defs_loc s_ops l_ops
+ s: StdSet s_ops
+ l: StdList l_ops
for s_ops :: "('x,'s,'more1) set_ops_scheme"
and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
lemma g_set_to_listl_correct:
assumes I: "s.invar s"
shows "List.set (l.α (g_set_to_listl s)) = s.α s"
and "l.invar (g_set_to_listl s)"
and "distinct (l.α (g_set_to_listl s))"
using I apply -
unfolding g_set_to_listl_def
apply (rule_tac I="λit σ. l.invar σ ∧ List.set (l.α σ) = it
∧ distinct (l.α σ)"
in s.iterate_rule_insert_P, auto simp: l.correct)+
done
lemma g_set_to_listr_correct:
assumes I: "s.invar s"
shows "List.set (l.α (g_set_to_listr s)) = s.α s"
and "l.invar (g_set_to_listr s)"
and "distinct (l.α (g_set_to_listr s))"
using I apply -
unfolding g_set_to_listr_def
apply (rule_tac I="λit σ. l.invar σ ∧ List.set (l.α σ) = it
∧ distinct (l.α σ)"
in s.iterate_rule_insert_P, auto simp: l.correct)+
done
end
end
Theory PrioByAnnotatedList
section ‹\isaheader{Implementing Priority Queues by Annotated Lists}›
theory PrioByAnnotatedList
imports
"../spec/AnnotatedListSpec"
"../spec/PrioSpec"
begin
text ‹
In this theory, we implement priority queues by annotated lists.
The implementation is realized as a generic adapter from the
AnnotatedList to the priority queue interface.
Priority queues are realized as a sequence of pairs of
elements and associated priority. The monoids operation
takes the element with minimum priority.
The element with minimum priority is extracted from the
sum over all elements.
Deleting the element with minimum priority is done by
splitting the sequence at the point where the minimum priority
of the elements read so far becomes equal to the minimum priority of
all elements.
›
subsection "Definitions"
subsubsection "Monoid"
datatype ('e, 'a) Prio = Infty | Prio 'e 'a
fun p_unwrap :: "('e,'a) Prio ⇒ ('e × 'a)" where
"p_unwrap (Prio e a) = (e , a)"
fun p_min :: "('e, 'a::linorder) Prio ⇒ ('e, 'a) Prio ⇒ ('e, 'a) Prio" where
"p_min Infty Infty = Infty"|
"p_min Infty (Prio e a) = Prio e a"|
"p_min (Prio e a) Infty = Prio e a"|
"p_min (Prio e1 a) (Prio e2 b) = (if a ≤ b then Prio e1 a else Prio e2 b)"
lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
apply(induct a b rule: p_min.induct )
apply auto
apply (induct c)
apply auto
apply (induct c)
apply auto
done
lemma lp_mono: "class.monoid_add p_min Infty"
by unfold_locales (auto simp add: p_min_asso)
instantiation Prio :: (type,linorder) monoid_add
begin
definition zero_def: "0 == Infty"
definition plus_def: "a+b == p_min a b"
instance by
intro_classes
(auto simp add: p_min_asso zero_def plus_def)
end
fun p_less_eq :: "('e, 'a::linorder) Prio ⇒ ('e, 'a) Prio ⇒ bool" where
"p_less_eq (Prio e a) (Prio f b) = (a ≤ b)"|
"p_less_eq _ Infty = True"|
"p_less_eq Infty (Prio e a) = False"
fun p_less :: "('e, 'a::linorder) Prio ⇒ ('e, 'a) Prio ⇒ bool" where
"p_less (Prio e a) (Prio f b) = (a < b)"|
"p_less (Prio e a) Infty = True"|
"p_less Infty _ = False"
lemma p_less_le_not_le : "p_less x y ⟷ p_less_eq x y ∧ ¬ (p_less_eq y x)"
by (induct x y rule: p_less.induct) auto
lemma p_order_refl : "p_less_eq x x"
by (induct x) auto
lemma p_le_inf : "p_less_eq Infty x ⟹ x = Infty"
by (induct x) auto
lemma p_order_trans : "⟦p_less_eq x y; p_less_eq y z⟧ ⟹ p_less_eq x z"
apply (induct y z rule: p_less.induct)
apply auto
apply (induct x)
apply auto
apply (cases x)
apply auto
apply(induct x)
apply (auto simp add: p_le_inf)
apply (metis p_le_inf p_less_eq.simps(2))
done
lemma p_linear2 : "p_less_eq x y ∨ p_less_eq y x"
apply (induct x y rule: p_less_eq.induct)
apply auto
done
instantiation Prio :: (type, linorder) preorder
begin
definition plesseq_def: "less_eq = p_less_eq"
definition pless_def: "less = p_less"
instance
apply (intro_classes)
apply (simp only: p_less_le_not_le pless_def plesseq_def)
apply (simp only: p_order_refl plesseq_def pless_def)
apply (simp only: plesseq_def)
apply (metis p_order_trans)
done
end
subsubsection "Operations"
definition alprio_α :: "('s ⇒ (unit × ('e,'a::linorder) Prio) list)
⇒ 's ⇒ ('e × 'a::linorder) multiset"
where
"alprio_α α al == (mset (map p_unwrap (map snd (α al))))"
definition alprio_invar :: "('s ⇒ (unit × ('c, 'd::linorder) Prio) list)
⇒ ('s ⇒ bool) ⇒ 's ⇒ bool"
where
"alprio_invar α invar al == invar al ∧ (∀ x∈set (α al). snd x≠Infty)"
definition alprio_empty where
"alprio_empty empt = empt"
definition alprio_isEmpty where
"alprio_isEmpty isEmpty = isEmpty"
definition alprio_insert :: "(unit ⇒ ('e,'a) Prio ⇒ 's ⇒ 's)
⇒ 'e ⇒ 'a::linorder ⇒ 's ⇒ 's"
where
"alprio_insert consl e a s = consl () (Prio e a) s"
definition alprio_find :: "('s ⇒ ('e,'a::linorder) Prio) ⇒ 's ⇒ ('e × 'a)"
where
"alprio_find annot s = p_unwrap (annot s)"
definition alprio_delete :: "((('e,'a::linorder) Prio ⇒ bool)
⇒ ('e,'a) Prio ⇒ 's ⇒ ('s × (unit × ('e,'a) Prio) × 's))
⇒ ('s ⇒ ('e,'a) Prio) ⇒ ('s ⇒ 's ⇒ 's) ⇒ 's ⇒ 's"
where
"alprio_delete splits annot app s = (let (l, _ , r)
= splits (λ x. x≤(annot s)) Infty s in app l r) "
definition alprio_meld where
"alprio_meld app = app"
lemmas alprio_defs =
alprio_invar_def
alprio_α_def
alprio_empty_def
alprio_isEmpty_def
alprio_insert_def
alprio_find_def
alprio_delete_def
alprio_meld_def
subsection "Correctness"
subsubsection "Auxiliary Lemmas"
lemma sum_list_split: "sum_list (l @ (a::'a::monoid_add) # r) = (sum_list l) + a + (sum_list r)"
by (induct l) (auto simp add: add.assoc)
lemma p_linear: "(x::('e, 'a::linorder) Prio) ≤ y ∨ y ≤ x"
by (unfold plesseq_def) (simp only: p_linear2)
lemma p_min_mon: "(x::(('e,'a::linorder) Prio)) ≤ y ⟹ (z + x) ≤ y"
apply (unfold plus_def plesseq_def)
apply (induct x y rule: p_less_eq.induct)
apply (auto)
apply (induct z)
apply (auto)
done
lemma p_min_mon2: "p_less_eq x y ⟹ p_less_eq (p_min z x) y"
apply (induct x y rule: p_less_eq.induct)
apply (auto)
apply (induct z)
apply (auto)
done
lemma ls_min: " ∀x ∈ set (xs:: ('e,'a::linorder) Prio list) . sum_list xs ≤ x"
proof (induct xs)
case Nil thus ?case by auto
next
case (Cons a ins) thus ?case
apply (auto simp add: plus_def plesseq_def)
apply (cases a)
apply auto
apply (cases "sum_list ins")
apply auto
apply (case_tac x)
apply auto
apply (cases a)
apply auto
apply (cases "sum_list ins")
apply auto
done
qed
lemma infadd: "x ≠ Infty ⟹x + y ≠ Infty"
apply (unfold plus_def)
apply (induct x y rule: p_min.induct)
apply auto
done
lemma prio_selects_one: "a+b = a ∨ a+b=(b::('e,'a::linorder) Prio)"
apply (simp add: plus_def)
apply (cases "(a,b)" rule: p_min.cases)
apply simp_all
done
lemma sum_list_in_set: "(l::('x × ('e,'a::linorder) Prio) list)≠[] ⟹
sum_list (map snd l) ∈ set (map snd l)"
apply (induct l)
apply simp
apply (case_tac l)
apply simp
using prio_selects_one
apply auto
apply force
apply force
done
lemma p_unwrap_less_sum: "snd (p_unwrap ((Prio e aa) + b)) ≤ aa"
apply (cases b)
apply (auto simp add: plus_def)
done
lemma prio_add_alb: "¬ b ≤ (a::('e,'a::linorder)Prio) ⟹ b + a = a"
by (auto simp add: plus_def, cases "(a,b)" rule: p_min.cases) (auto simp add: plesseq_def)
lemma prio_add_alb2: " (a::('e,'a::linorder)Prio) ≤ a + b ⟹ a + b = a"
by (auto simp add: plus_def, cases "(a,b)" rule: p_min.cases) (auto simp add: plesseq_def)
lemma prio_add_abc:
assumes "(l::('e,'a::linorder)Prio) + a ≤ c"
and "¬ l ≤ c"
shows "¬ l ≤ a"
proof (rule ccontr)
assume "¬ ¬ l ≤ a"
with assms have "l + a = l"
apply (auto simp add: plus_def plesseq_def)
apply (cases "(l,a)" rule: p_less_eq.cases)
apply auto
done
with assms show False by simp
qed
lemma prio_add_abc2:
assumes "(a::('e,'a::linorder)Prio) ≤ a + b"
shows "a ≤ b"
proof (rule ccontr)
assume ann: "¬ a ≤ b"
hence "a + b = b"
apply (auto simp add: plus_def plesseq_def)
apply (cases "(a,b)" rule: p_min.cases)
apply auto
done
thus False using assms ann by simp
qed
subsubsection "Empty"
lemma alprio_empty_correct:
assumes "al_empty α invar empt"
shows "prio_empty (alprio_α α) (alprio_invar α invar) (alprio_empty empt)"
proof -
interpret al_empty α invar empt by fact
show ?thesis
apply (unfold_locales)
apply (unfold alprio_invar_def)
apply auto
apply (unfold alprio_empty_def)
apply (auto simp add: empty_correct)
apply (unfold alprio_α_def)
apply auto
apply (simp only: empty_correct)
done
qed
subsubsection "Is Empty"
lemma alprio_isEmpty_correct:
assumes "al_isEmpty α invar isEmpty"
shows "prio_isEmpty (alprio_α α) (alprio_invar α invar) (alprio_isEmpty isEmpty)"
proof -
interpret al_isEmpty α invar isEmpty by fact
show ?thesis by (unfold_locales) (auto simp add: alprio_defs isEmpty_correct)
qed
subsubsection "Insert"
lemma alprio_insert_correct:
assumes "al_consl α invar consl"
shows "prio_insert (alprio_α α) (alprio_invar α invar) (alprio_insert consl)"
proof -
interpret al_consl α invar consl by fact
show ?thesis by unfold_locales (auto simp add: alprio_defs consl_correct)
qed
subsubsection "Meld"
lemma alprio_meld_correct:
assumes "al_app α invar app"
shows "prio_meld (alprio_α α) (alprio_invar α invar) (alprio_meld app)"
proof -
interpret al_app α invar app by fact
show ?thesis by unfold_locales (auto simp add: alprio_defs app_correct)
qed
subsubsection "Find"
lemma annot_not_inf :
assumes "(alprio_invar α invar) s"
and "(alprio_α α) s ≠ {#}"
and "al_annot α invar annot"
shows "annot s ≠ Infty"
proof -
interpret al_annot α invar annot by fact
show ?thesis
proof -
from assms(1) have invs: "invar s" by (simp add: alprio_defs)
from assms(2) have sne: "set (α s) ≠ {}"
proof (cases "set (α s) = {}")
case True
hence "α s = []" by simp
hence "(alprio_α α) s = {#}" by (simp add: alprio_defs)
from this assms(2) show ?thesis by simp
next
case False thus ?thesis by simp
qed
hence "(α s) ≠ []" by simp
hence " ∃x xs. (α s) = x # xs" by (cases "α s") auto
from this obtain x xs where [simp]: "(α s) = x # xs" by blast
from this assms(1) have "snd x ≠ Infty" by (auto simp add: alprio_defs)
hence "sum_list (map snd (α s)) ≠ Infty" by (auto simp add: infadd)
thus "annot s ≠ Infty" using annot_correct invs by simp
qed
qed
lemma annot_in_set:
assumes "(alprio_invar α invar) s"
and "(alprio_α α) s ≠ {#}"
and "al_annot α invar annot"
shows "p_unwrap (annot s) ∈# ((alprio_α α) s)"
proof -
interpret al_annot α invar annot by fact
from assms(2) have snn: "α s ≠ []" by (auto simp add: alprio_defs)
from assms(1) have invs: "invar s" by (simp add: alprio_defs)
hence ans: "annot s = sum_list (map snd (α s))" by (simp add: annot_correct)
let ?P = "map snd (α s)"
have "annot s ∈ set ?P"
by (unfold ans) (rule sum_list_in_set[OF snn])
then show ?thesis
by (auto intro!: image_eqI simp add: alprio_α_def)
qed
lemma sum_list_less_elems: "∀x∈set xs. snd x ≠ Infty ⟹
∀y∈set_mset (mset (map p_unwrap (map snd xs))).
snd (p_unwrap (sum_list (map snd xs))) ≤ snd y"
proof (induct xs)
case Nil thus ?case by simp
next
case (Cons a as) thus ?case
apply auto
apply (cases "(snd a)" rule: p_unwrap.cases)
apply auto
apply (cases "sum_list (map snd as)")
apply auto
apply (metis linorder_linear p_min_re_neut
p_unwrap.simps plus_def [abs_def] snd_eqD)
apply (auto simp add: p_unwrap_less_sum)
apply (unfold plus_def)
apply (cases "(snd a, sum_list (map snd as))" rule: p_min.cases)
apply auto
apply (cases "map snd as")
apply (auto simp add: infadd)
done
qed
lemma alprio_find_correct:
assumes "al_annot α invar annot"
shows "prio_find (alprio_α α) (alprio_invar α invar) (alprio_find annot)"
proof -
interpret al_annot α invar annot by fact
show ?thesis
apply unfold_locales
apply (rule conjI)
apply (insert assms)
apply (unfold alprio_find_def)
apply (simp add:annot_in_set)
apply (unfold alprio_defs)
apply (simp add: annot_correct)
apply (auto simp add: sum_list_less_elems)
done
qed
subsubsection "Delete"
lemma delpred_mon:
"∀(a:: ('e, 'a::linorder) Prio) b. ((λ x. x ≤ y) a
⟶ (λ x. x ≤ y) (a + b)) "
proof (intro impI allI)
fix a b
show "a ≤ y ⟹ a + b ≤ y"
apply (induct a b rule: p_less.induct)
apply (auto simp add: plus_def)
apply (metis linorder_linear order_trans
p_linear p_min.simps(4) p_min_mon plus_def prio_selects_one)
apply (metis order_trans p_linear p_min_mon p_min_re_neut plus_def)
done
qed
lemma alpriodel_invar:
assumes "alprio_invar α invar s"
and "al_annot α invar annot"
and "alprio_α α s ≠ {#}"
and "al_splits α invar splits"
and "al_app α invar app"
shows "alprio_invar α invar (alprio_delete splits annot app s)"
proof -
interpret al_splits α invar splits by fact
let ?P = "λx. x ≤ annot s"
obtain l p r where
[simp]:"splits ?P Infty s = (l, p, r)"
by (cases "splits ?P Infty s") auto
obtain e a where
"p = (e, a)"
by (cases p, blast)
hence
lear:"splits ?P Infty s = (l, (e,a), r)"
by simp
from annot_not_inf[OF assms(1) assms(3) assms(2)] have
"annot s ≠ Infty" .
hence
sv1: "¬ Infty ≤ annot s"
by (simp add: plesseq_def, cases "annot s", auto)
from assms(1) have
invs: "invar s"
unfolding alprio_invar_def by simp
interpret al_annot α invar annot by fact
from invs have
sv2: "Infty + sum_list (map snd (α s)) ≤ annot s"
by (auto simp add: annot_correct plus_def
plesseq_def p_min_le_neut p_order_refl)
note sp = splits_correct[of s "?P" Infty l e a r]
note dp = delpred_mon[of "annot s"]
from sp[OF invs dp sv1 sv2 lear] have
invlr: "invar l ∧ invar r" and
alr: "α s = α l @ (e, a) # α r"
by auto
interpret al_app α invar app by fact
from invlr app_correct have
invapplr: "invar (app l r)"
by simp
from invlr app_correct have
sr: "α (app l r) = (α l) @ (α r)"
by simp
from alr have
"set (α s) ⊇ (set (α l) Un set (α r))"
by auto
with app_correct[of l r] invlr have
"set (α s) ⊇ set (α (app l r))" by auto
with invapplr assms(1)
show ?thesis
unfolding alprio_defs by auto
qed
lemma sum_list_elem:
assumes " ins = l @ (a::('e,'a::linorder)Prio) # r"
and "¬ sum_list l ≤ sum_list ins"
and "sum_list l + a ≤ sum_list ins "
shows " a = sum_list ins"
proof -
have "¬ sum_list l ≤ a" using assms prio_add_abc by simp
hence lpa: "sum_list l + a = a" using prio_add_alb by auto
hence als: "a ≤ sum_list ins" using assms(3) by simp
have "sum_list ins = a + sum_list r"
using lpa sum_list_split[of l a r] assms(1) by auto
thus ?thesis using prio_add_alb2[of a "sum_list r"] prio_add_abc2 als
by auto
qed
lemma alpriodel_right:
assumes "alprio_invar α invar s"
and "al_annot α invar annot"
and "alprio_α α s ≠ {#}"
and "al_splits α invar splits"
and "al_app α invar app"
shows "alprio_α α (alprio_delete splits annot app s) =
alprio_α α s - {#p_unwrap (annot s)#}"
proof -
interpret al_splits α invar splits by fact
let ?P = "λx. x ≤ annot s"
obtain l p r where
[simp]:"splits ?P Infty s = (l, p, r)"
by (cases "splits ?P Infty s") auto
obtain e a where
"p = (e, a)"
by (cases p, blast)
hence
lear:"splits ?P Infty s = (l, (e,a), r)"
by simp
from annot_not_inf[OF assms(1) assms(3) assms(2)] have
"annot s ≠ Infty" .
hence
sv1: "¬ Infty ≤ annot s"
by (simp add: plesseq_def, cases "annot s", auto)
from assms(1) have
invs: "invar s"
unfolding alprio_invar_def by simp
interpret al_annot α invar annot by fact
from invs have
sv2: "Infty + sum_list (map snd (α s)) ≤ annot s"
by (auto simp add: annot_correct plus_def
plesseq_def p_min_le_neut p_order_refl)
note sp = splits_correct[of s "?P" Infty l e a r]
note dp = delpred_mon[of "annot s"]
from sp[OF invs dp sv1 sv2 lear] have
invlr: "invar l ∧ invar r" and
alr: "α s = α l @ (e, a) # α r" and
anlel: "¬ sum_list (map snd (α l)) ≤ annot s" and
aneqa: "(sum_list (map snd (α l)) + a) ≤ annot s"
by (auto simp add: plus_def zero_def)
have mapalr: "map snd (α s) = (map snd (α l)) @ a # (map snd (α r))"
using alr by simp
note lsa = sum_list_elem[of "map snd (α s)" "map snd (α l)" a "map snd (α r)"]
note lsa2 = lsa[OF mapalr]
hence a_is_annot: "a = annot s"
using annot_correct[OF invs] anlel aneqa by auto
have "map p_unwrap (map snd (α s)) =
(map p_unwrap (map snd (α l))) @ (p_unwrap a)
# (map p_unwrap (map snd (α r)))"
using alr by simp
hence alpriolst: "(alprio_α α s) = (alprio_α α l) +{# p_unwrap a #}+ (alprio_α α r)"
unfolding alprio_defs
by (simp add: algebra_simps)
interpret al_app α invar app by fact
from alpriolst show ?thesis using app_correct[of l r] invlr a_is_annot
by (auto simp add: alprio_defs algebra_simps)
qed
lemma alprio_delete_correct:
assumes "al_annot α invar annot"
and "al_splits α invar splits"
and "al_app α invar app"
shows "prio_delete (alprio_α α) (alprio_invar α invar)
(alprio_find annot) (alprio_delete splits annot app)"
proof-
interpret al_annot α invar annot by fact
interpret al_splits α invar splits by fact
interpret al_app α invar app by fact
show ?thesis
apply intro_locales
apply (rule alprio_find_correct,simp add: assms)
apply unfold_locales
apply (insert assms)
apply (simp add: alpriodel_invar)
apply (simp add: alpriodel_right alprio_find_def)
done
qed
lemmas alprio_correct =
alprio_empty_correct
alprio_isEmpty_correct
alprio_insert_correct
alprio_delete_correct
alprio_find_correct
alprio_meld_correct
locale alprio_defs = StdALDefs ops
for ops :: "(unit,('e,'a::linorder) Prio,'s) alist_ops"
begin
definition [icf_rec_def]: "alprio_ops ≡ ⦇
prio_op_α = alprio_α α,
prio_op_invar = alprio_invar α invar,
prio_op_empty = alprio_empty empty,
prio_op_isEmpty = alprio_isEmpty isEmpty,
prio_op_insert = alprio_insert consl,
prio_op_find = alprio_find annot,
prio_op_delete = alprio_delete splits annot app,
prio_op_meld = alprio_meld app
⦈"
end
locale alprio = alprio_defs ops + StdAL ops
for ops :: "(unit,('e,'a::linorder) Prio,'s) alist_ops"
begin
lemma alprio_ops_impl: "StdPrio alprio_ops"
apply (rule StdPrio.intro)
apply (simp_all add: icf_rec_unf)
apply (rule alprio_correct, unfold_locales) []
apply (rule alprio_correct, unfold_locales) []
apply (rule alprio_correct, unfold_locales) []
apply (rule alprio_correct, unfold_locales) []
apply (rule alprio_correct, unfold_locales) []
apply (rule alprio_correct, unfold_locales) []
done
end
end
Theory PrioUniqueByAnnotatedList
section ‹\isaheader{Implementing Unique Priority Queues by Annotated Lists}›
theory PrioUniqueByAnnotatedList
imports
"../spec/AnnotatedListSpec"
"../spec/PrioUniqueSpec"
begin
text ‹
In this theory we use annotated lists to implement unique priority queues
with totally ordered elements.
This theory is written as a generic adapter from the AnnotatedList interface
to the unique priority queue interface.
The annotated list stores a sequence of elements annotated with
priorities\footnote{Technically, the annotated list elements are of unit-type,
and the annotations hold both, the priority queue elements and the priorities.
This is required as we defined annotated lists to only sum up the elements
annotations.}
The monoids operations forms the maximum over the elements and
the minimum over the priorities.
The sequence of pairs is ordered by ascending elements' order.
The insertion point for a new element, or the priority of an existing element
can be found by splitting the
sequence at the point where the maximum of the elements read so far gets
bigger than the element to be inserted.
The minimum priority can be read out as the sum over the whole sequence.
Finding the element with minimum priority is done by splitting the sequence
at the point where the minimum priority of the elements read so far becomes
equal to the minimum priority of the whole sequence.
›
subsection "Definitions"
subsubsection "Monoid"
datatype ('e, 'a) LP = Infty | LP 'e 'a
fun p_unwrap :: "('e,'a) LP ⇒ ('e × 'a)" where
"p_unwrap (LP e a) = (e , a)"
fun p_min :: "('e::linorder, 'a::linorder) LP ⇒ ('e, 'a) LP ⇒ ('e, 'a) LP" where
"p_min Infty Infty = Infty"|
"p_min Infty (LP e a) = LP e a"|
"p_min (LP e a) Infty = LP e a"|
"p_min (LP e1 a) (LP e2 b) = (LP (max e1 e2) (min a b))"
fun e_less_eq :: "'e ⇒ ('e::linorder, 'a::linorder) LP ⇒ bool" where
"e_less_eq e Infty = False"|
"e_less_eq e (LP e' _) = (e ≤ e')"
text_raw‹\paragraph{Instantiation of classes}\ \\›
lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
apply(induct a b rule: p_min.induct )
apply (auto)
apply (induct c)
apply (auto)
apply (metis max.assoc)
apply (metis min.assoc)
done
lemma lp_mono: "class.monoid_add p_min Infty" by unfold_locales (auto simp add: p_min_asso)
instantiation LP :: (linorder,linorder) monoid_add
begin
definition zero_def: "0 == Infty"
definition plus_def: "a+b == p_min a b"
instance by
intro_classes
(auto simp add: p_min_asso zero_def plus_def)
end
fun p_less_eq :: "('e, 'a::linorder) LP ⇒ ('e, 'a) LP ⇒ bool" where
"p_less_eq (LP e a) (LP f b) = (a ≤ b)"|
"p_less_eq _ Infty = True"|
"p_less_eq Infty (LP e a) = False"
fun p_less :: "('e, 'a::linorder) LP ⇒ ('e, 'a) LP ⇒ bool" where
"p_less (LP e a) (LP f b) = (a < b)"|
"p_less (LP e a) Infty = True"|
"p_less Infty _ = False"
lemma p_less_le_not_le : "p_less x y ⟷ p_less_eq x y ∧ ¬ (p_less_eq y x)"
by (induct x y rule: p_less.induct) auto
lemma p_order_refl : "p_less_eq x x"
by (induct x) auto
lemma p_le_inf : "p_less_eq Infty x ⟹ x = Infty"
by (induct x) auto
lemma p_order_trans : "⟦p_less_eq x y; p_less_eq y z⟧ ⟹ p_less_eq x z"
apply (induct y z rule: p_less.induct)
apply auto
apply (induct x)
apply auto
apply (cases x)
apply auto
apply(induct x)
apply (auto simp add: p_le_inf)
apply (metis p_le_inf p_less_eq.simps(2))
done
lemma p_linear2 : "p_less_eq x y ∨ p_less_eq y x"
apply (induct x y rule: p_less_eq.induct)
apply auto
done
instantiation LP :: (type, linorder) preorder
begin
definition plesseq_def: "less_eq = p_less_eq"
definition pless_def: "less = p_less"
instance
apply (intro_classes)
apply (simp only: p_less_le_not_le pless_def plesseq_def)
apply (simp only: p_order_refl plesseq_def pless_def)
apply (simp only: plesseq_def)
apply (metis p_order_trans)
done
end
subsubsection "Operations"
definition aluprio_α :: "('s ⇒ (unit × ('e::linorder,'a::linorder) LP) list)
⇒ 's ⇒ ('e::linorder ⇀ 'a::linorder)"
where
"aluprio_α α ft == (map_of (map p_unwrap (map snd (α ft))))"
definition aluprio_invar :: "('s ⇒ (unit × ('c::linorder, 'd::linorder) LP) list)
⇒ ('s ⇒ bool) ⇒ 's ⇒ bool"
where
"aluprio_invar α invar ft ==
invar ft
∧ (∀ x∈set (α ft). snd x≠Infty)
∧ sorted (map fst (map p_unwrap (map snd (α ft))))
∧ distinct (map fst (map p_unwrap (map snd (α ft)))) "
definition aluprio_empty where
"aluprio_empty empt = empt"
definition aluprio_isEmpty where
"aluprio_isEmpty isEmpty = isEmpty"
definition aluprio_insert ::
"((('e::linorder,'a::linorder) LP ⇒ bool)
⇒ ('e,'a) LP ⇒ 's ⇒ ('s × (unit × ('e,'a) LP) × 's))
⇒ ('s ⇒ ('e,'a) LP)
⇒ ('s ⇒ bool)
⇒ ('s ⇒ 's ⇒ 's)
⇒ ('s ⇒ unit ⇒ ('e,'a) LP ⇒ 's)
⇒ 's ⇒ 'e ⇒ 'a ⇒ 's"
where
"
aluprio_insert splits annot isEmpty app consr s e a =
(if e_less_eq e (annot s) ∧ ¬ isEmpty s
then
(let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in
(if e < fst (p_unwrap lp)
then
app (consr (consr l () (LP e a)) () lp) r
else
app (consr l () (LP e a)) r ))
else
consr s () (LP e a))
"
definition aluprio_pop :: "((('e::linorder,'a::linorder) LP ⇒ bool) ⇒ ('e,'a) LP
⇒ 's ⇒ ('s × (unit × ('e,'a) LP) × 's))
⇒ ('s ⇒ ('e,'a) LP)
⇒ ('s ⇒ 's ⇒ 's)
⇒ 's
⇒ 'e ×'a ×'s"
where
"aluprio_pop splits annot app s =
(let (l, (_,lp) , r) = splits (λ x. x ≤ (annot s)) Infty s
in
(case lp of
(LP e a) ⇒
(e, a, app l r) ))"
definition aluprio_prio ::
"((('e::linorder,'a::linorder) LP ⇒ bool) ⇒ ('e,'a) LP ⇒ 's
⇒ ('s × (unit × ('e,'a) LP) × 's))
⇒ ('s ⇒ ('e,'a) LP)
⇒ ('s ⇒ bool)
⇒ 's ⇒ 'e ⇒ 'a option"
where
"
aluprio_prio splits annot isEmpty s e =
(if e_less_eq e (annot s) ∧ ¬ isEmpty s
then
(let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in
(if e = fst (p_unwrap lp)
then
Some (snd (p_unwrap lp))
else
None))
else
None)
"
lemmas aluprio_defs =
aluprio_invar_def
aluprio_α_def
aluprio_empty_def
aluprio_isEmpty_def
aluprio_insert_def
aluprio_pop_def
aluprio_prio_def
subsection "Correctness"
subsubsection "Auxiliary Lemmas"
lemma p_linear: "(x::('e, 'a::linorder) LP) ≤ y ∨ y ≤ x"
by (unfold plesseq_def) (simp only: p_linear2)
lemma e_less_eq_mon1: "e_less_eq e x ⟹ e_less_eq e (x + y)"
apply (cases x)
apply (auto simp add: plus_def)
apply (cases y)
apply (auto simp add: max.coboundedI1)
done
lemma e_less_eq_mon2: "e_less_eq e y ⟹ e_less_eq e (x + y)"
apply (cases x)
apply (auto simp add: plus_def)
apply (cases y)
apply (auto simp add: max.coboundedI2)
done
lemmas e_less_eq_mon =
e_less_eq_mon1
e_less_eq_mon2
lemma p_less_eq_mon:
"(x::('e::linorder,'a::linorder) LP) ≤ z ⟹ (x + y) ≤ z"
apply(cases y)
apply(auto simp add: plus_def)
apply (cases x)
apply (cases z)
apply (auto simp add: plesseq_def)
apply (cases z)
apply (auto simp add: min.coboundedI1)
done
lemma p_less_eq_lem1:
"⟦¬ (x::('e::linorder,'a::linorder) LP) ≤ z;
(x + y) ≤ z⟧
⟹ y ≤ z "
apply (cases x,auto simp add: plus_def)
apply (cases y, auto)
apply (cases z, auto simp add: plesseq_def)
apply (metis min_le_iff_disj)
done
lemma infadd: "x ≠ Infty ⟹x + y ≠ Infty"
apply (unfold plus_def)
apply (induct x y rule: p_min.induct)
apply auto
done
lemma e_less_eq_sum_list:
"⟦¬ e_less_eq e (sum_list xs)⟧ ⟹ ∀x ∈ set xs. ¬ e_less_eq e x"
proof (induct xs)
case Nil thus ?case by simp
next
case (Cons a xs)
hence "¬ e_less_eq e (sum_list xs)" by (auto simp add: e_less_eq_mon)
hence v1: "∀x∈set xs. ¬ e_less_eq e x" using Cons.hyps by simp
from Cons.prems have "¬ e_less_eq e a" by (auto simp add: e_less_eq_mon)
with v1 show "∀x∈set (a#xs). ¬ e_less_eq e x" by simp
qed
lemma e_less_eq_p_unwrap:
"⟦x ≠ Infty;¬ e_less_eq e x⟧ ⟹ fst (p_unwrap x) < e"
by (cases x) auto
lemma e_less_eq_refl :
"b ≠ Infty ⟹ e_less_eq (fst (p_unwrap b)) b"
by (cases b) auto
lemma e_less_eq_sum_list2:
assumes
"∀x∈set (αs). snd x ≠ Infty"
"((), b) ∈ set (αs)"
shows "e_less_eq (fst (p_unwrap b)) (sum_list (map snd (αs)))"
apply(insert assms)
apply (induct "αs")
apply (auto simp add: zero_def e_less_eq_mon e_less_eq_refl)
done
lemma e_less_eq_lem1:
"⟦¬ e_less_eq e a;e_less_eq e (a + b)⟧ ⟹ e_less_eq e b"
apply (auto simp add: plus_def)
apply (cases a)
apply auto
apply (cases b)
apply auto
apply (metis le_max_iff_disj)
done
lemma p_unwrap_less_sum: "snd (p_unwrap ((LP e aa) + b)) ≤ aa"
apply (cases b)
apply (auto simp add: plus_def)
done
lemma sum_list_less_elems: "∀x∈set xs. snd x ≠ Infty ⟹
∀y∈set (map snd (map p_unwrap (map snd xs))).
snd (p_unwrap (sum_list (map snd xs))) ≤ y"
proof (induct xs)
case Nil thus ?case by simp
next
case (Cons a as) thus ?case
apply auto
apply (cases "(snd a)" rule: p_unwrap.cases)
apply auto
apply (cases "sum_list (map snd as)")
apply auto
apply (metis linorder_linear p_min_re_neut p_unwrap.simps
plus_def[abs_def] snd_eqD)
apply (auto simp add: p_unwrap_less_sum)
apply (unfold plus_def)
apply (cases "(snd a, sum_list (map snd as))" rule: p_min.cases)
apply auto
apply (cases "map snd as")
apply (auto simp add: infadd)
apply (metis min.coboundedI2 snd_conv)
done
qed
lemma distinct_sortet_list_app:
"⟦sorted xs; distinct xs; xs = as @ b # cs⟧
⟹ ∀ x∈ set cs. b < x"
by (metis distinct.simps(2) distinct_append
antisym_conv2 sorted.simps(2) sorted_append)
lemma distinct_sorted_list_lem1:
assumes
"sorted xs"
"sorted ys"
"distinct xs"
"distinct ys"
" ∀ x ∈ set xs. x < e"
" ∀ y ∈ set ys. e < y"
shows
"sorted (xs @ e # ys)"
"distinct (xs @ e # ys)"
proof -
from assms (5,6)
have "∀x∈set xs. ∀y∈set ys. x ≤ y" by force
thus "sorted (xs @ e # ys)"
using assms
by (auto simp add: sorted_append)
have "set xs ∩ set ys = {}" using assms (5,6) by force
thus "distinct (xs @ e # ys)"
using assms
by (auto)
qed
lemma distinct_sorted_list_lem2:
assumes
"sorted xs"
"sorted ys"
"distinct xs"
"distinct ys"
"e < e'"
" ∀ x ∈ set xs. x < e"
" ∀ y ∈ set ys. e' < y"
shows
"sorted (xs @ e # e' # ys)"
"distinct (xs @ e # e' # ys)"
proof -
have "sorted (e' # ys)"
"distinct (e' # ys)"
"∀ y ∈ set (e' # ys). e < y"
using assms(2,4,5,7)
by (auto)
thus "sorted (xs @ e # e' # ys)"
"distinct (xs @ e # e' # ys)"
using assms(1,3,6) distinct_sorted_list_lem1[of xs "e' # ys" e]
by auto
qed
lemma map_of_distinct_upd:
"x ∉ set (map fst xs) ⟹ [x ↦ y] ++ map_of xs = (map_of xs) (x ↦ y)"
by (induct xs) (auto simp add: fun_upd_twist)
lemma map_of_distinct_upd2:
assumes "x ∉ set(map fst xs)"
"x ∉ set (map fst ys)"
shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys))(x ↦ y)"
apply(insert assms)
apply(induct xs)
apply (auto intro: ext)
done
lemma map_of_distinct_upd3:
assumes "x ∉ set(map fst xs)"
"x ∉ set (map fst ys)"
shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ (x,y') # ys))(x ↦ y)"
apply(insert assms)
apply(induct xs)
apply (auto intro: ext)
done
lemma map_of_distinct_upd4:
assumes "x ∉ set(map fst xs)"
"x ∉ set (map fst ys)"
shows "map_of (xs @ ys) = (map_of (xs @ (x,y) # ys))(x := None)"
apply(insert assms)
apply(induct xs)
apply clarsimp
apply (metis dom_map_of_conv_image_fst fun_upd_None_restrict
restrict_complement_singleton_eq restrict_map_self)
apply (auto simp add: map_of_eq_None_iff) []
done
lemma map_of_distinct_lookup:
assumes "x ∉ set(map fst xs)"
"x ∉ set (map fst ys)"
shows "map_of (xs @ (x,y) # ys) x = Some y"
proof -
have "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys)) (x ↦ y)"
using assms map_of_distinct_upd2 by simp
thus ?thesis
by simp
qed
lemma ran_distinct:
assumes dist: "distinct (map fst al)"
shows "ran (map_of al) = snd ` set al"
using assms proof (induct al)
case Nil then show ?case by simp
next
case (Cons kv al)
then have "ran (map_of al) = snd ` set al" by simp
moreover from Cons.prems have "map_of al (fst kv) = None"
by (simp add: map_of_eq_None_iff)
ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed
subsubsection "Finite"
lemma aluprio_finite_correct: "uprio_finite (aluprio_α α) (aluprio_invar α invar)"
by(unfold_locales) (simp add: aluprio_defs finite_dom_map_of)
subsubsection "Empty"
lemma aluprio_empty_correct:
assumes "al_empty α invar empt"
shows "uprio_empty (aluprio_α α) (aluprio_invar α invar) (aluprio_empty empt)"
proof -
interpret al_empty α invar empt by fact
show ?thesis
apply (unfold_locales)
apply (auto simp add: empty_correct aluprio_defs)
done
qed
subsubsection "Is Empty"
lemma aluprio_isEmpty_correct:
assumes "al_isEmpty α invar isEmpty"
shows "uprio_isEmpty (aluprio_α α) (aluprio_invar α invar) (aluprio_isEmpty isEmpty)"
proof -
interpret al_isEmpty α invar isEmpty by fact
show ?thesis
apply (unfold_locales)
apply (auto simp add: aluprio_defs isEmpty_correct)
done
qed
subsubsection "Insert"
lemma annot_inf:
assumes A: "invar s" "∀x∈set (α s). snd x ≠ Infty" "al_annot α invar annot"
shows "annot s = Infty ⟷ α s = [] "
proof -
from A have invs: "invar s" by (simp add: aluprio_defs)
interpret al_annot α invar annot by fact
show "annot s = Infty ⟷ α s = []"
proof (cases "α s = []")
case True
hence "map snd (α s) = []" by simp
hence "sum_list (map snd (α s)) = Infty"
by (auto simp add: zero_def)
with invs have "annot s = Infty" by (auto simp add: annot_correct)
with True show ?thesis by simp
next
case False
hence " ∃x xs. (α s) = x # xs" by (cases "α s") auto
from this obtain x xs where [simp]: "(α s) = x # xs" by blast
from this assms(2) have "snd x ≠ Infty" by (auto simp add: aluprio_defs)
hence "sum_list (map snd (α s)) ≠ Infty" by (auto simp add: infadd)
thus ?thesis using annot_correct invs False by simp
qed
qed
lemma e_less_eq_annot:
assumes "al_annot α invar annot"
"invar s" "∀x∈set (α s). snd x ≠ Infty" "¬ e_less_eq e (annot s)"
shows "∀x ∈ set (map (fst ∘ (p_unwrap ∘ snd)) (α s)). x < e"
proof -
interpret al_annot α invar annot by fact
from assms(2) have "annot s = sum_list (map snd (α s))"
by (auto simp add: annot_correct)
with assms(4) have
"∀x ∈ set (map snd (α s)). ¬ e_less_eq e x"
by (metis e_less_eq_sum_list)
with assms(3)
show ?thesis
by (auto simp add: e_less_eq_p_unwrap)
qed
lemma aluprio_insert_correct:
assumes
"al_splits α invar splits"
"al_annot α invar annot"
"al_isEmpty α invar isEmpty"
"al_app α invar app"
"al_consr α invar consr"
shows
"uprio_insert (aluprio_α α) (aluprio_invar α invar)
(aluprio_insert splits annot isEmpty app consr)"
proof -
interpret al_splits α invar splits by fact
interpret al_annot α invar annot by fact
interpret al_isEmpty α invar isEmpty by fact
interpret al_app α invar app by fact
interpret al_consr α invar consr by fact
show ?thesis
proof (unfold_locales, unfold aluprio_defs, goal_cases)
case g1asms: (1 s e a)
thus ?case proof (cases "e_less_eq e (annot s) ∧ ¬ isEmpty s")
case False with g1asms show ?thesis
apply (auto simp add: consr_correct )
proof goal_cases
case prems: 1
with assms(2) have
"∀x ∈ set (map (fst ∘ (p_unwrap ∘ snd)) (α s)). x < e"
by (simp add: e_less_eq_annot)
with prems(3) show ?case
by(auto simp add: sorted_append)
next
case prems: 2
hence "annot s = sum_list (map snd (α s))"
by (simp add: annot_correct)
with prems
show ?case
by (auto simp add: e_less_eq_sum_list2)
next
case prems: 3
hence "α s = []" by (auto simp add: isEmpty_correct)
thus ?case by simp
next
case prems: 4
hence "α s = []" by (auto simp add: isEmpty_correct)
with prems show ?case by simp
qed
next
case True note T1 = this
obtain l uu lp r where
l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
by (cases "splits (e_less_eq e) Infty s", auto)
note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
have
v3: "invar s"
"¬ e_less_eq e Infty"
"e_less_eq e (Infty + sum_list (map snd (α s)))"
using T1 g1asms annot_correct
by (auto simp add: plus_def)
have
v4: "α s = α l @ ((), lp) # α r"
"¬ e_less_eq e (Infty + sum_list (map snd (α l)))"
"e_less_eq e (Infty + sum_list (map snd (α l)) + lp)"
"invar l"
"invar r"
using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
hence v5: "e_less_eq e lp"
by (metis e_less_eq_lem1)
hence v6: "e ≤ (fst (p_unwrap lp))"
by (cases lp) auto
have "(Infty + sum_list (map snd (α l))) = (annot l)"
by (metis add_0_left annot_correct v4(4) zero_def)
hence v7:"¬ e_less_eq e (annot l)"
using v4(2) by simp
have "∀x∈set (α l). snd x ≠ Infty"
using g1asms v4(1) by simp
hence v7: "∀x ∈ set (map (fst ∘ (p_unwrap ∘ snd)) (α l)). x < e"
using v4(4) v7 assms(2)
by(simp add: e_less_eq_annot)
have v8:"map fst (map p_unwrap (map snd (α s))) =
map fst (map p_unwrap (map snd (α l))) @ fst(p_unwrap lp) #
map fst (map p_unwrap (map snd (α r)))"
using v4(1)
by simp
note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (α s)))"
"map fst (map p_unwrap (map snd (α l)))" "fst(p_unwrap lp)"
"map fst (map p_unwrap (map snd (α r)))"]
hence v9:
"∀ x∈set (map (fst ∘ (p_unwrap ∘ snd)) (α r)). fst(p_unwrap lp) < x"
using v4(1) g1asms v8
by auto
have v10:
"sorted (map fst (map p_unwrap (map snd (α l))))"
"distinct (map fst (map p_unwrap (map snd (α l))))"
"sorted (map fst (map p_unwrap (map snd (α r))))"
"distinct (map fst (map p_unwrap (map snd (α l))))"
using g1asms v8
by (auto simp add: sorted_append)
from l_lp_r T1 g1asms show ?thesis
proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
case True
hence v11:
"aluprio_insert splits annot isEmpty app consr s e a
= app (consr (consr l () (LP e a)) () lp) r"
using l_lp_r T1
by (auto simp add: aluprio_defs)
have v12: "invar (app (consr (consr l () (LP e a)) () lp) r)"
using v4(4,5)
by (auto simp add: app_correct consr_correct)
have v13:
"α (app (consr (consr l () (LP e a)) () lp) r)
= α l @ ((),(LP e a)) # ((), lp) # α r"
using v4(4,5) by (auto simp add: app_correct consr_correct)
hence v14:
"(∀x∈set (α (app (consr (consr l () (LP e a)) () lp) r)).
snd x ≠ Infty)"
using g1asms v4(1)
by auto
have v15: "e = fst(p_unwrap (LP e a))" by simp
hence v16:
"sorted (map fst (map p_unwrap
(map snd (α l @ ((),(LP e a)) # ((), lp) # α r))))"
"distinct (map fst (map p_unwrap
(map snd (α l @ ((),(LP e a)) # ((), lp) # α r))))"
using v10(1,3) v7 True v9 v4(1) g1asms distinct_sorted_list_lem2
by (auto simp add: sorted_append)
thus "invar (aluprio_insert splits annot isEmpty app consr s e a) ∧
(∀x∈set (α (aluprio_insert splits annot isEmpty app consr s e a)).
snd x ≠ Infty) ∧
sorted (map fst (map p_unwrap (map snd (α
(aluprio_insert splits annot isEmpty app consr s e a))))) ∧
distinct (map fst (map p_unwrap (map snd (α
(aluprio_insert splits annot isEmpty app consr s e a)))))"
using v11 v12 v13 v14
by simp
next
case False
hence v11:
"aluprio_insert splits annot isEmpty app consr s e a
= app (consr l () (LP e a)) r"
using l_lp_r T1
by (auto simp add: aluprio_defs)
have v12: "invar (app (consr l () (LP e a)) r)" using v4(4,5)
by (auto simp add: app_correct consr_correct)
have v13: "α (app (consr l () (LP e a)) r) = α l @ ((),(LP e a)) # α r"
using v4(4,5) by (auto simp add: app_correct consr_correct)
hence v14: "(∀x∈set (α (app (consr l () (LP e a)) r)). snd x ≠ Infty)"
using g1asms v4(1)
by auto
have v15: "e = fst(p_unwrap (LP e a))" by simp
have v16: "e = fst(p_unwrap lp)"
using False v5 by (cases lp) auto
hence v17:
"sorted (map fst (map p_unwrap
(map snd (α l @ ((),(LP e a)) # α r))))"
"distinct (map fst (map p_unwrap
(map snd (α l @ ((),(LP e a)) # α r))))"
using v16 v15 v10(1,3) v7 True v9 v4(1)
g1asms distinct_sorted_list_lem1
by (auto simp add: sorted_append)
thus "invar (aluprio_insert splits annot isEmpty app consr s e a) ∧
(∀x∈set (α (aluprio_insert splits annot isEmpty app consr s e a)).
snd x ≠ Infty) ∧
sorted (map fst (map p_unwrap (map snd (α
(aluprio_insert splits annot isEmpty app consr s e a))))) ∧
distinct (map fst (map p_unwrap (map snd (α
(aluprio_insert splits annot isEmpty app consr s e a)))))"
using v11 v12 v13 v14
by simp
qed
qed
next
case g1asms: (2 s e a)
thus ?case proof (cases "e_less_eq e (annot s) ∧ ¬ isEmpty s")
case False with g1asms show ?thesis
apply (auto simp add: consr_correct)
proof goal_cases
case prems: 1
with assms(2) have
"∀x ∈ set (map (fst ∘ (p_unwrap ∘ snd)) (α s)). x < e"
by (simp add: e_less_eq_annot)
hence "e ∉ set (map fst ((map (p_unwrap ∘ snd)) (α s)))"
by auto
thus ?case
by (auto simp add: map_of_distinct_upd)
next
case prems: 2
hence "α s = []" by (auto simp add: isEmpty_correct)
thus ?case
by simp
qed
next
case True note T1 = this
obtain l lp r where
l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
by (cases "splits (e_less_eq e) Infty s", auto)
note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
have
v3: "invar s"
"¬ e_less_eq e Infty"
"e_less_eq e (Infty + sum_list (map snd (α s)))"
using T1 g1asms annot_correct
by (auto simp add: plus_def)
have
v4: "α s = α l @ ((), lp) # α r"
"¬ e_less_eq e (Infty + sum_list (map snd (α l)))"
"e_less_eq e (Infty + sum_list (map snd (α l)) + lp)"
"invar l"
"invar r"
using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
hence v5: "e_less_eq e lp"
by (metis e_less_eq_lem1)
hence v6: "e ≤ (fst (p_unwrap lp))"
by (cases lp) auto
have "(Infty + sum_list (map snd (α l))) = (annot l)"
by (metis add_0_left annot_correct v4(4) zero_def)
hence v7:"¬ e_less_eq e (annot l)"
using v4(2) by simp
have "∀x∈set (α l). snd x ≠ Infty"
using g1asms v4(1) by simp
hence v7: "∀x ∈ set (map (fst ∘ (p_unwrap ∘ snd)) (α l)). x < e"
using v4(4) v7 assms(2)
by(simp add: e_less_eq_annot)
have v8:"map fst (map p_unwrap (map snd (α s))) =
map fst (map p_unwrap (map snd (α l))) @ fst(p_unwrap lp) #
map fst (map p_unwrap (map snd (α r)))"
using v4(1)
by simp
note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (α s)))"
"map fst (map p_unwrap (map snd (α l)))" "fst(p_unwrap lp)"
"map fst (map p_unwrap (map snd (α r)))"]
hence v9: "
∀ x∈set (map (fst ∘ (p_unwrap ∘ snd)) (α r)). fst(p_unwrap lp) < x"
using v4(1) g1asms v8
by auto
hence v10: " ∀ x∈set (map (fst ∘ (p_unwrap ∘ snd)) (α r)). e < x"
using v6 by auto
have v11:
"e ∉ set (map fst (map p_unwrap (map snd (α l))))"
"e ∉ set (map fst (map p_unwrap (map snd (α r))))"
using v7 v10 v8 g1asms
by auto
from l_lp_r T1 g1asms show ?thesis
proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
case True
hence v12:
"aluprio_insert splits annot isEmpty app consr s e a
= app (consr (consr l () (LP e a)) () lp) r"
using l_lp_r T1
by (auto simp add: aluprio_defs)
have v13:
"α (app (consr (consr l () (LP e a)) () lp) r)
= α l @ ((),(LP e a)) # ((), lp) # α r"
using v4(4,5) by (auto simp add: app_correct consr_correct)
have v14: "e = fst(p_unwrap (LP e a))" by simp
have v15: "e ∉ set (map fst (map p_unwrap (map snd(((),lp)#α r))))"
using v11(2) True by auto
note map_of_distinct_upd2[OF v11(1) v15]
thus
"map_of (map p_unwrap (map snd (α
(aluprio_insert splits annot isEmpty app consr s e a))))
= map_of (map p_unwrap (map snd (α s)))(e ↦ a)"
using v12 v13 v4(1)
by simp
next
case False
hence v12:
"aluprio_insert splits annot isEmpty app consr s e a
= app (consr l () (LP e a)) r"
using l_lp_r T1
by (auto simp add: aluprio_defs)
have v13:
"α (app (consr l () (LP e a)) r) = α l @ ((),(LP e a)) # α r"
using v4(4,5) by (auto simp add: app_correct consr_correct)
have v14: "e = fst(p_unwrap lp)"
using False v5 by (cases lp) auto
note v15 = map_of_distinct_upd3[OF v11(1) v11(2)]
have v16:"(map p_unwrap (map snd (α s))) =
(map p_unwrap (map snd (α l))) @ (e,snd(p_unwrap lp)) #
(map p_unwrap (map snd (α r)))"
using v4(1) v14
by simp
note v15[of a "snd(p_unwrap lp)"]
thus
"map_of (map p_unwrap (map snd (α
(aluprio_insert splits annot isEmpty app consr s e a))))
= map_of (map p_unwrap (map snd (α s)))(e ↦ a)"
using v12 v13 v16
by simp
qed
qed
qed
qed
subsubsection "Prio"
lemma aluprio_prio_correct:
assumes
"al_splits α invar splits"
"al_annot α invar annot"
"al_isEmpty α invar isEmpty"
shows
"uprio_prio (aluprio_α α) (aluprio_invar α invar) (aluprio_prio splits annot isEmpty)"
proof -
interpret al_splits α invar splits by fact
interpret al_annot α invar annot by fact
interpret al_isEmpty α invar isEmpty by fact
show ?thesis
proof (unfold_locales)
fix s e
assume inv1: "aluprio_invar α invar s"
hence sinv: "invar s"
"(∀ x∈set (α s). snd x≠Infty)"
"sorted (map fst (map p_unwrap (map snd (α s))))"
"distinct (map fst (map p_unwrap (map snd (α s))))"
by (auto simp add: aluprio_defs)
show "aluprio_prio splits annot isEmpty s e = aluprio_α α s e"
proof(cases "e_less_eq e (annot s) ∧ ¬ isEmpty s")
case False note F1 = this
thus ?thesis
proof(cases "isEmpty s")
case True
hence "α s = []"
using sinv isEmpty_correct by simp
hence "aluprio_α α s = Map.empty" by (simp add:aluprio_defs)
hence "aluprio_α α s e = None" by simp
thus "aluprio_prio splits annot isEmpty s e = aluprio_α α s e"
using F1
by (auto simp add: aluprio_defs)
next
case False
hence v3:"¬ e_less_eq e (annot s)" using F1 by simp
note v4=e_less_eq_annot[OF assms(2)]
note v4[OF sinv(1) sinv(2) v3]
hence v5:"e∉set (map (fst ∘ (p_unwrap ∘ snd)) (α s))"
by auto
hence "map_of (map (p_unwrap ∘ snd) (α s)) e = None"
using map_of_eq_None_iff
by (metis map_map map_of_eq_None_iff set_map v5)
thus "aluprio_prio splits annot isEmpty s e = aluprio_α α s e"
using F1
by (auto simp add: aluprio_defs)
qed
next
case True note T1 = this
obtain l uu lp r where
l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
by (cases "splits (e_less_eq e) Infty s", auto)
note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
have
v3: "invar s"
"¬ e_less_eq e Infty"
"e_less_eq e (Infty + sum_list (map snd (α s)))"
using T1 sinv annot_correct
by (auto simp add: plus_def)
have
v4: "α s = α l @ ((), lp) # α r"
"¬ e_less_eq e (Infty + sum_list (map snd (α l)))"
"e_less_eq e (Infty + sum_list (map snd (α l)) + lp)"
"invar l"
"invar r"
using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
hence v5: "e_less_eq e lp"
by (metis e_less_eq_lem1)
hence v6: "e ≤ (fst (p_unwrap lp))"
by (cases lp) auto
have "(Infty + sum_list (map snd (α l))) = (annot l)"
by (metis add_0_left annot_correct v4(4) zero_def)
hence v7:"¬ e_less_eq e (annot l)"
using v4(2) by simp
have "∀x∈set (α l). snd x ≠ Infty"
using sinv v4(1) by simp
hence v7: "∀x ∈ set (map (fst ∘ (p_unwrap ∘ snd)) (α l)). x < e"
using v4(4) v7 assms(2)
by(simp add: e_less_eq_annot)
have v8:"map fst (map p_unwrap (map snd (α s))) =
map fst (map p_unwrap (map snd (α l))) @ fst(p_unwrap lp) #
map fst (map p_unwrap (map snd (α r)))"
using v4(1)
by simp
note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (α s)))"
"map fst (map p_unwrap (map snd (α l)))" "fst(p_unwrap lp)"
"map fst (map p_unwrap (map snd (α r)))"]
hence v9:
"∀ x∈set (map (fst ∘ (p_unwrap ∘ snd)) (α r)). fst(p_unwrap lp) < x"
using v4(1) sinv v8
by auto
hence v10: " ∀ x∈set (map (fst ∘ (p_unwrap ∘ snd)) (α r)). e < x"
using v6 by auto
have v11:
"e ∉ set (map fst (map p_unwrap (map snd (α l))))"
"e ∉ set (map fst (map p_unwrap (map snd (α r))))"
using v7 v10 v8 sinv
by auto
from l_lp_r T1 sinv show ?thesis
proof (cases "e = fst (p_unwrap lp)")
case False
have v12: "e ∉ set (map fst (map p_unwrap (map snd(α s))))"
using v11 False v4(1) by auto
hence "map_of (map (p_unwrap ∘ snd) (α s)) e = None"
using map_of_eq_None_iff
by (metis map_map map_of_eq_None_iff set_map v12)
thus ?thesis
using T1 False l_lp_r
by (auto simp add: aluprio_defs)
next
case True
have v12: "map (p_unwrap ∘ snd) (α s) =
map p_unwrap (map snd (α l)) @ (e,snd (p_unwrap lp)) #
map p_unwrap (map snd (α r))"
using v4(1) True by simp
note map_of_distinct_lookup[OF v11]
hence
"map_of (map (p_unwrap ∘ snd) (α s)) e = Some (snd (p_unwrap lp))"
using v12 by simp
thus ?thesis
using T1 True l_lp_r
by (auto simp add: aluprio_defs)
qed
qed
qed
qed
subsubsection "Pop"
lemma aluprio_pop_correct:
assumes "al_splits α invar splits"
"al_annot α invar annot"
"al_app α invar app"
shows
"uprio_pop (aluprio_α α) (aluprio_invar α invar) (aluprio_pop splits annot app)"
proof -
interpret al_splits α invar splits by fact
interpret al_annot α invar annot by fact
interpret al_app α invar app by fact
show ?thesis
proof (unfold_locales)
fix s e a s'
assume A: "aluprio_invar α invar s"
"aluprio_α α s ≠ Map.empty"
"aluprio_pop splits annot app s = (e, a, s')"
hence v1: "α s ≠ []"
by (auto simp add: aluprio_defs)
obtain l lp r where
l_lp_r: "splits (λ x. x≤annot s) Infty s = (l,((),lp),r)"
by (cases "splits (λ x. x≤annot s) Infty s", auto)
have invs:
"invar s"
"(∀x∈set (α s). snd x ≠ Infty)"
"sorted (map fst (map p_unwrap (map snd (α s))))"
"distinct (map fst (map p_unwrap (map snd (α s))))"
using A by (auto simp add:aluprio_defs)
note a1 = annot_inf[of invar s α annot]
note a1[OF invs(1) invs(2) assms(2)]
hence v2: "annot s ≠ Infty"
using v1 by simp
hence v3:
"¬ Infty ≤ annot s"
by(cases "annot s") (auto simp add: plesseq_def)
have v4: "annot s = sum_list (map snd (α s))"
by (auto simp add: annot_correct invs(1))
hence
v5:
"(Infty + sum_list (map snd (α s))) ≤ annot s"
by (auto simp add: plus_def)
note p_mon = p_less_eq_mon[of _ "annot s"]
note v6 = splits_correct[OF invs(1)]
note v7 = v6[of "λ x. x ≤ annot s"]
note v7[OF _ v3 v5 l_lp_r] p_mon
hence v8:
" α s = α l @ ((), lp) # α r"
"¬ Infty + sum_list (map snd (α l)) ≤ annot s"
"Infty + sum_list (map snd (α l)) + lp ≤ annot s"
"invar l"
"invar r"
by auto
hence v9: "lp ≠ Infty"
using invs(2) by auto
hence v10:
"s' = app l r"
"(e,a) = p_unwrap lp"
using l_lp_r A(3)
apply (auto simp add: aluprio_defs)
apply (cases lp)
apply auto
apply (cases lp)
apply auto
done
have "lp ≤ annot s"
using v8(2,3) p_less_eq_lem1
by auto
hence v11: "a ≤ snd (p_unwrap (annot s))"
using v10(2) v2 v9
apply (cases "annot s")
apply auto
apply (cases lp)
apply (auto simp add: plesseq_def)
done
note sum_list_less_elems[OF invs(2)]
hence v12: "∀y∈set (map snd (map p_unwrap (map snd (α s)))). a ≤ y"
using v4 v11 by auto
have "ran (aluprio_α α s) = set (map snd (map p_unwrap (map snd (α s))))"
using ran_distinct[OF invs(4)]
apply (unfold aluprio_defs)
apply (simp only: set_map)
done
hence ziel1: "∀y∈ran (aluprio_α α s). a ≤ y"
using v12 by simp
have v13:
"map p_unwrap (map snd (α s))
= map p_unwrap (map snd (α l)) @ (e,a) # map p_unwrap (map snd (α r))"
using v8(1) v10 by auto
hence v14:
"map fst (map p_unwrap (map snd (α s)))
= map fst (map p_unwrap (map snd (α l))) @ e
# map fst (map p_unwrap (map snd (α r)))"
by auto
hence v15:
"e ∉ set (map fst (map p_unwrap (map snd (α l))))"
"e ∉ set (map fst (map p_unwrap (map snd (α r))))"
using invs(4) by auto
note map_of_distinct_lookup[OF v15]
note this[of a]
hence ziel2: "aluprio_α α s e = Some a"
using v13
by (unfold aluprio_defs, auto)
have v16:
"α s' = α l @ α r"
"invar s'"
using v8(4,5) app_correct v10 by auto
note map_of_distinct_upd4[OF v15]
note this[of a]
hence
ziel3: "aluprio_α α s' = (aluprio_α α s)(e := None)"
unfolding aluprio_defs
using v16(1) v13 by auto
have ziel4: "aluprio_invar α invar s'"
using v16 v8(1) invs(2,3,4)
unfolding aluprio_defs
by (auto simp add: sorted_append)
show "aluprio_invar α invar s' ∧
aluprio_α α s' = (aluprio_α α s)(e := None) ∧
aluprio_α α s e = Some a ∧ (∀y∈ran (aluprio_α α s). a ≤ y)"
using ziel1 ziel2 ziel3 ziel4 by simp
qed
qed
lemmas aluprio_correct =
aluprio_finite_correct
aluprio_empty_correct
aluprio_isEmpty_correct
aluprio_insert_correct
aluprio_pop_correct
aluprio_prio_correct
locale aluprio_defs = StdALDefs ops
for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
begin
definition [icf_rec_def]: "aluprio_ops ≡ ⦇
upr_α = aluprio_α α,
upr_invar = aluprio_invar α invar,
upr_empty = aluprio_empty empty,
upr_isEmpty = aluprio_isEmpty isEmpty,
upr_insert = aluprio_insert splits annot isEmpty app consr,
upr_pop = aluprio_pop splits annot app,
upr_prio = aluprio_prio splits annot isEmpty
⦈"
end
locale aluprio = aluprio_defs ops + StdAL ops
for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
begin
lemma aluprio_ops_impl: "StdUprio aluprio_ops"
apply (rule StdUprio.intro)
apply (simp_all add: icf_rec_unf)
apply (rule aluprio_correct)
apply (rule aluprio_correct, unfold_locales) []
apply (rule aluprio_correct, unfold_locales) []
apply (rule aluprio_correct, unfold_locales) []
apply (rule aluprio_correct, unfold_locales) []
apply (rule aluprio_correct, unfold_locales) []
done
end
end
Theory ICF_Impl_Chapter
theory ICF_Impl_Chapter imports Main begin
text_raw ‹\isasection{Implementations} \label{ch:Impl}›
end
Theory ListMapImpl
section ‹\isaheader{Map Implementation by Associative Lists}›
theory ListMapImpl
imports
"../spec/MapSpec"
"../../Lib/Assoc_List"
"../gen_algo/MapGA"
begin
text_raw ‹\label{thy:ListMapImpl}›
type_synonym ('k,'v) lm = "('k,'v) assoc_list"
definition [icf_rec_def]: "lm_basic_ops ≡ ⦇
bmap_op_α = Assoc_List.lookup,
bmap_op_invar = λ_. True,
bmap_op_empty = (λ_::unit. Assoc_List.empty),
bmap_op_lookup = (λk m. Assoc_List.lookup m k),
bmap_op_update = Assoc_List.update,
bmap_op_update_dj = Assoc_List.update,
bmap_op_delete = Assoc_List.delete,
bmap_op_list_it = Assoc_List.iteratei
⦈"
setup Locale_Code.open_block
interpretation lm_basic: StdBasicMapDefs lm_basic_ops .
interpretation lm_basic: StdBasicMap lm_basic_ops
apply unfold_locales
apply (simp_all add: icf_rec_unf
Assoc_List.lookup_empty' Assoc_List.iteratei_correct map_upd_eq_restrict)
done
setup Locale_Code.close_block
definition [icf_rec_def]: "lm_ops ≡ lm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation lm: StdMapDefs lm_ops .
interpretation lm: StdMap lm_ops
unfolding lm_ops_def
by (rule lm_basic.dflt_ops_impl)
interpretation lm: StdMap_no_invar lm_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "lm"›
lemma pi_lm[proper_it]:
"proper_it' Assoc_List.iteratei Assoc_List.iteratei"
unfolding Assoc_List.iteratei_def[abs_def]
by (intro icf_proper_iteratorI proper_it'I)
interpretation pi_lm: proper_it_loc Assoc_List.iteratei Assoc_List.iteratei
apply unfold_locales
apply (rule pi_lm)
done
lemma pi_lm'[proper_it]:
"proper_it' lm.iteratei lm.iteratei"
unfolding lm.iteratei_def[abs_def]
by (intro icf_proper_iteratorI proper_it'I)
interpretation pi_lm': proper_it_loc lm.iteratei lm.iteratei
apply unfold_locales
apply (rule pi_lm')
done
text ‹Code generator test›
definition "test_codegen ≡ (
lm.add ,
lm.add_dj ,
lm.ball ,
lm.bex ,
lm.delete ,
lm.empty ,
lm.isEmpty ,
lm.isSng ,
lm.iterate ,
lm.iteratei ,
lm.list_it ,
lm.lookup ,
lm.restrict ,
lm.sel ,
lm.size ,
lm.size_abort ,
lm.sng ,
lm.to_list ,
lm.to_map ,
lm.update ,
lm.update_dj)"
export_code test_codegen checking SML
end
Theory ListMapImpl_Invar
section ‹\isaheader{Map Implementation by Association Lists with explicit invariants}›
theory ListMapImpl_Invar
imports
"../spec/MapSpec"
"../../Lib/Assoc_List"
"../gen_algo/MapGA"
begin
text_raw ‹\label{thy:ListMapImpl_Invar}›
type_synonym ('k,'v) lmi = "('k×'v) list"
term revg
definition "lmi_α ≡ Map.map_of"
definition "lmi_invar ≡ λm. distinct (List.map fst m)"
definition lmi_basic_ops :: "('k,'v,('k,'v) lmi) map_basic_ops"
where [icf_rec_def]: "lmi_basic_ops ≡ ⦇
bmap_op_α = lmi_α,
bmap_op_invar = lmi_invar,
bmap_op_empty = (λ_::unit. []),
bmap_op_lookup = (λk m. Map.map_of m k),
bmap_op_update = AList.update,
bmap_op_update_dj = (λk v m. (k, v) # m),
bmap_op_delete = AList.delete_aux,
bmap_op_list_it = foldli
⦈"
setup Locale_Code.open_block
interpretation lmi_basic: StdBasicMapDefs lmi_basic_ops .
interpretation lmi_basic: StdBasicMap lmi_basic_ops
unfolding lmi_basic_ops_def
apply unfold_locales
apply (simp_all
add: icf_rec_unf lmi_α_def lmi_invar_def
add: AList.update_conv' AList.distinct_update AList.map_of_delete_aux'
map_iterator_foldli_correct dom_map_of_conv_image_fst map_upd_eq_restrict
)
done
setup Locale_Code.close_block
definition [icf_rec_def]: "lmi_ops ≡ lmi_basic.dflt_ops ⦇
map_op_add_dj := revg,
map_op_to_list := id,
map_op_size := length,
map_op_isEmpty := case_list True (λ_ _. False),
map_op_isSng := (λl. case l of [_] ⇒ True | _ ⇒ False)
⦈"
setup Locale_Code.open_block
interpretation lmi: StdMapDefs lmi_ops .
interpretation lmi: StdMap lmi_ops
proof -
interpret aux: StdMap lmi_basic.dflt_ops by (rule lmi_basic.dflt_ops_impl)
have [simp]: "map_add_dj lmi_α lmi_invar revg"
apply (unfold_locales)
apply (auto simp: lmi_α_def lmi_invar_def)
apply (blast intro: map_add_comm)
apply (simp add: rev_map[symmetric])
apply fastforce
done
have [simp]: "map_to_list lmi_α lmi_invar id"
apply unfold_locales
by (simp_all add: lmi_α_def lmi_invar_def)
have [simp]: "map_isEmpty lmi_α lmi_invar (case_list True (λ_ _. False))"
apply unfold_locales
unfolding lmi_α_def lmi_invar_def
by (simp split: list.split)
have [simp]: "map_isSng lmi_α lmi_invar
(λl. case l of [_] ⇒ True | _ ⇒ False)"
apply unfold_locales
unfolding lmi_α_def lmi_invar_def
apply (auto split: list.split)
apply (metis (no_types) map_upd_nonempty)
by (metis fun_upd_other fun_upd_same option.simps(3))
have [simp]: "map_size_axioms lmi_α lmi_invar length"
apply unfold_locales
unfolding lmi_α_def lmi_invar_def
by (metis card_dom_map_of)
show "StdMap lmi_ops"
unfolding lmi_ops_def
apply (rule StdMap_intro)
apply (simp_all)
apply intro_locales
apply (simp_all add: icf_rec_unf)
done
qed
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "lmi"›
lemma pi_lmi[proper_it]:
"proper_it' foldli foldli"
by (intro proper_it'I icf_proper_iteratorI)
interpretation pi_lmi: proper_it_loc foldli foldli
apply unfold_locales
apply (rule pi_lmi)
done
definition lmi_from_list_dj :: "('k×'v) list ⇒ ('k,'v) lmi" where
"lmi_from_list_dj ≡ id"
lemma lmi_from_list_dj_correct:
assumes [simp]: "distinct (map fst l)"
shows "lmi.α (lmi_from_list_dj l) = map_of l"
"lmi.invar (lmi_from_list_dj l)"
by (auto simp add: lmi_from_list_dj_def icf_rec_unf lmi_α_def lmi_invar_def)
text ‹Code generator test›
definition "test_codegen ≡ (
lmi.add ,
lmi.add_dj ,
lmi.ball ,
lmi.bex ,
lmi.delete ,
lmi.empty ,
lmi.isEmpty ,
lmi.isSng ,
lmi.iterate ,
lmi.iteratei ,
lmi.list_it ,
lmi.lookup ,
lmi.restrict ,
lmi.sel ,
lmi.size ,
lmi.size_abort ,
lmi.sng ,
lmi.to_list ,
lmi.to_map ,
lmi.update ,
lmi.update_dj,
lmi_from_list_dj
)"
export_code test_codegen checking SML
end
Theory RBTMapImpl
section ‹\isaheader{Map Implementation by Red-Black-Trees}›
theory RBTMapImpl
imports
"../spec/MapSpec"
"../../Lib/RBT_add"
"HOL-Library.RBT"
"../gen_algo/MapGA"
begin
text_raw ‹\label{thy:RBTMapImpl}›
hide_const (open) RBT.map RBT.fold RBT.foldi RBT.empty RBT.insert
type_synonym ('k,'v) rm = "('k,'v) RBT.rbt"
definition rm_basic_ops :: "('k::linorder,'v,('k,'v) rm) omap_basic_ops"
where [icf_rec_def]: "rm_basic_ops ≡ ⦇
bmap_op_α = RBT.lookup,
bmap_op_invar = λ_. True,
bmap_op_empty = (λ_::unit. RBT.empty),
bmap_op_lookup = (λk m. RBT.lookup m k),
bmap_op_update = RBT.insert,
bmap_op_update_dj = RBT.insert,
bmap_op_delete = RBT.delete,
bmap_op_list_it = (λr. RBT_add.rm_iterateoi (RBT.impl_of r)),
bmap_op_ordered_list_it = (λr. RBT_add.rm_iterateoi (RBT.impl_of r)),
bmap_op_rev_list_it = (λr. RBT_add.rm_reverse_iterateoi (RBT.impl_of r))
⦈"
setup Locale_Code.open_block
interpretation rm_basic: StdBasicOMap rm_basic_ops
apply unfold_locales
apply (simp_all add: rm_basic_ops_def map_upd_eq_restrict)
apply (rule map_iterator_linord_is_it)
apply dup_subgoals
unfolding RBT.lookup_def
apply simp_all
apply (rule rm_iterateoi_correct)
apply simp
apply (rule rm_reverse_iterateoi_correct)
apply simp
done
setup Locale_Code.close_block
definition [icf_rec_def]: "rm_ops ≡ rm_basic.dflt_oops⦇map_op_add := RBT.union⦈"
setup Locale_Code.open_block
interpretation rm: StdOMap rm_ops
proof -
interpret aux1: StdOMap rm_basic.dflt_oops
unfolding rm_ops_def
by (rule rm_basic.dflt_oops_impl)
interpret aux2: map_add RBT.lookup "λ_. True" RBT.union
apply unfold_locales
apply (rule lookup_union)
.
show "StdOMap rm_ops"
apply (rule StdOMap_intro)
apply icf_locales
done
qed
interpretation rm: StdMap_no_invar rm_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "rm"›
lemma pi_rm[proper_it]:
"proper_it' RBT_add.rm_iterateoi RBT_add.rm_iterateoi"
apply (rule proper_it'I)
by (induct_tac s) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)
lemma pi_rm_rev[proper_it]:
"proper_it' RBT_add.rm_reverse_iterateoi RBT_add.rm_reverse_iterateoi"
apply (rule proper_it'I)
by (induct_tac s) (simp_all add: rm_reverse_iterateoi_alt_def
icf_proper_iteratorI)
interpretation pi_rm: proper_it_loc RBT_add.rm_iterateoi RBT_add.rm_iterateoi
apply unfold_locales by (rule pi_rm)
interpretation pi_rm_rev: proper_it_loc RBT_add.rm_reverse_iterateoi
RBT_add.rm_reverse_iterateoi
apply unfold_locales by (rule pi_rm_rev)
text ‹Code generator test›
definition "test_codegen ≡ (rm.add ,
rm.add_dj ,
rm.ball ,
rm.bex ,
rm.delete ,
rm.empty ,
rm.isEmpty ,
rm.isSng ,
rm.iterate ,
rm.iteratei ,
rm.iterateo ,
rm.iterateoi ,
rm.list_it ,
rm.lookup ,
rm.max ,
rm.min ,
rm.restrict ,
rm.rev_iterateo ,
rm.rev_iterateoi ,
rm.rev_list_it ,
rm.reverse_iterateo ,
rm.reverse_iterateoi ,
rm.sel ,
rm.size ,
rm.size_abort ,
rm.sng ,
rm.to_list ,
rm.to_map ,
rm.to_rev_list ,
rm.to_sorted_list ,
rm.update ,
rm.update_dj)"
export_code test_codegen checking SML
end
Theory HashMap_Impl
section ‹\isaheader{Hash maps implementation}›
theory HashMap_Impl
imports
RBTMapImpl
ListMapImpl
"../../Lib/HashCode"
"../../Lib/Code_Target_ICF"
begin
text ‹
We use a red-black tree instead of an indexed array. This
has the disadvantage of being more complex, however we need not bother
about a fixed-size array and rehashing if the array becomes too full.
The entries of the red-black tree are lists of (key,value) pairs.
›
subsection ‹Abstract Hashmap›
text ‹
We first specify the behavior of our hashmap on the level of maps.
We will then show that our implementation based on hashcode-map and bucket-map
is a correct implementation of this specification.
›
type_synonym
('k,'v) abs_hashmap = "hashcode ⇀ ('k ⇀ 'v)"
abbreviation map_entry where "map_entry k f m == m(k := f (m k))"
definition ahm_invar:: "('k::hashable,'v) abs_hashmap ⇒ bool"
where "ahm_invar m ==
(∀hc cm k. m hc = Some cm ∧ k∈dom cm ⟶ hashcode k = hc) ∧
(∀hc cm. m hc = Some cm ⟶ cm ≠ Map.empty)"
definition ahm_α where
"ahm_α m k == case m (hashcode k) of
None ⇒ None |
Some cm ⇒ cm k"
definition ahm_lookup :: "'k::hashable ⇒ ('k,'v) abs_hashmap ⇒ 'v option"
where "ahm_lookup k m == (ahm_α m) k"
definition ahm_empty :: "('k::hashable,'v) abs_hashmap"
where "ahm_empty = Map.empty"
definition ahm_update where
"ahm_update k v m ==
case m (hashcode k) of
None ⇒ m (hashcode k ↦ [k ↦ v]) |
Some cm ⇒ m (hashcode k ↦ cm (k ↦ v))
"
definition ahm_delete where
"ahm_delete k m == map_entry (hashcode k)
(λv. case v of
None ⇒ None |
Some bm ⇒ (
if bm |` (- {k}) = Map.empty then
None
else
Some ( bm |` (- {k}))
)
) m
"
definition ahm_isEmpty where
"ahm_isEmpty m == m=Map.empty"
text ‹
Now follow correctness lemmas, that relate the hashmap operations to
operations on the corresponding map. Those lemmas are named op\_correct, where
(is) the operation.
›
lemma ahm_invarI: "⟦
!!hc cm k. ⟦m hc = Some cm; k∈dom cm⟧ ⟹ hashcode k = hc;
!!hc cm. ⟦ m hc = Some cm ⟧ ⟹ cm ≠ Map.empty
⟧ ⟹ ahm_invar m"
by (unfold ahm_invar_def) blast
lemma ahm_invarD: "⟦ ahm_invar m; m hc = Some cm; k∈dom cm ⟧ ⟹ hashcode k = hc"
by (unfold ahm_invar_def) blast
lemma ahm_invarDne: "⟦ ahm_invar m; m hc = Some cm ⟧ ⟹ cm ≠ Map.empty"
by (unfold ahm_invar_def) blast
lemma ahm_invar_bucket_not_empty[simp]:
"ahm_invar m ⟹ m hc ≠ Some Map.empty"
by (auto dest: ahm_invarDne)
lemmas ahm_lookup_correct = ahm_lookup_def
lemma ahm_empty_correct:
"ahm_α ahm_empty = Map.empty"
"ahm_invar ahm_empty"
apply (rule ext)
apply (unfold ahm_empty_def)
apply (auto simp add: ahm_α_def intro: ahm_invarI split: option.split)
done
lemma ahm_update_correct:
"ahm_α (ahm_update k v m) = ahm_α m (k ↦ v)"
"ahm_invar m ⟹ ahm_invar (ahm_update k v m)"
apply (rule ext)
apply (unfold ahm_update_def)
apply (auto simp add: ahm_α_def split: option.split)
apply (rule ahm_invarI)
apply (auto dest: ahm_invarD ahm_invarDne split: if_split_asm)
apply (rule ahm_invarI)
apply (auto dest: ahm_invarD split: if_split_asm)
apply (drule (1) ahm_invarD)
apply auto
done
lemma fun_upd_apply_ne: "x≠y ⟹ (f(x:=v)) y = f y"
by simp
lemma cancel_one_empty_simp: "m |` (-{k}) = Map.empty ⟷ dom m ⊆ {k}"
proof
assume "m |` (- {k}) = Map.empty"
hence "{} = dom (m |` (-{k}))" by auto
also have "… = dom m - {k}" by auto
finally show "dom m ⊆ {k}" by blast
next
assume "dom m ⊆ {k}"
hence "dom m - {k} = {}" by auto
hence "dom (m |` (-{k})) = {}" by auto
thus "m |` (-{k}) = Map.empty" by blast
qed
lemma ahm_delete_correct:
"ahm_α (ahm_delete k m) = (ahm_α m) |` (-{k})"
"ahm_invar m ⟹ ahm_invar (ahm_delete k m)"
apply (rule ext)
apply (unfold ahm_delete_def)
apply (auto simp add: ahm_α_def Let_def Map.restrict_map_def
split: option.split)[1]
apply (drule_tac x=x in fun_cong)
apply (auto)[1]
apply (rule ahm_invarI)
apply (auto split: if_split_asm option.split_asm dest: ahm_invarD)
apply (drule (1) ahm_invarD)
apply (auto simp add: restrict_map_def split: if_split_asm option.split_asm)
done
lemma ahm_isEmpty_correct: "ahm_invar m ⟹ ahm_isEmpty m ⟷ ahm_α m = Map.empty"
proof
assume "ahm_invar m" "ahm_isEmpty m"
thus "ahm_α m = Map.empty"
by (auto simp add: ahm_isEmpty_def ahm_α_def intro: ext)
next
assume I: "ahm_invar m"
and E: "ahm_α m = Map.empty"
show "ahm_isEmpty m"
proof (rule ccontr)
assume "¬ahm_isEmpty m"
then obtain hc bm where MHC: "m hc = Some bm"
by (unfold ahm_isEmpty_def)
(blast elim: nempty_dom dest: domD)
from ahm_invarDne[OF I, OF MHC] obtain k v where
BMK: "bm k = Some v"
by (blast elim: nempty_dom dest: domD)
from ahm_invarD[OF I, OF MHC] BMK have [simp]: "hashcode k = hc"
by auto
hence "ahm_α m k = Some v"
by (simp add: ahm_α_def MHC BMK)
with E show False by simp
qed
qed
lemmas ahm_correct = ahm_empty_correct ahm_lookup_correct ahm_update_correct
ahm_delete_correct ahm_isEmpty_correct
lemma ahm_be_is_e:
assumes I: "ahm_invar m"
assumes A: "m hc = Some bm" "bm k = Some v"
shows "ahm_α m k = Some v"
using A
apply (auto simp add: ahm_α_def split: option.split dest: ahm_invarD[OF I])
apply (frule ahm_invarD[OF I, where k=k])
apply auto
done
lemma ahm_e_is_be: "⟦
ahm_α m k = Some v;
!!bm. ⟦m (hashcode k) = Some bm; bm k = Some v ⟧ ⟹ P
⟧ ⟹ P"
by (unfold ahm_α_def)
(auto split: option.split_asm)
subsection ‹Concrete Hashmap›
text ‹
In this section, we define the concrete hashmap that is made from the
hashcode map and the bucket map.
We then show the correctness of the operations w.r.t. the abstract hashmap, and
thus, indirectly, w.r.t. the corresponding map.
›
type_synonym
('k,'v) hm_impl = "(hashcode, ('k,'v) lm) rm"
subsubsection "Operations"
definition rm_map_entry
:: "hashcode ⇒ ('v option ⇒ 'v option) ⇒ (hashcode, 'v) rm ⇒ (hashcode,'v) rm"
where
"rm_map_entry k f m ==
case rm.lookup k m of
None ⇒ (
case f None of
None ⇒ m |
Some v ⇒ rm.update k v m
) |
Some v ⇒ (
case f (Some v) of
None ⇒ rm.delete k m |
Some v' ⇒ rm.update k v' m
)
"
definition empty :: "unit ⇒ ('k :: hashable, 'v) hm_impl" where "empty == rm.empty"
definition update :: "'k::hashable ⇒ 'v ⇒ ('k,'v) hm_impl ⇒ ('k,'v) hm_impl"
where
"update k v m ==
let hc = hashcode k in
case rm.lookup hc m of
None ⇒ rm.update hc (lm.update k v (lm.empty ())) m |
Some bm ⇒ rm.update hc (lm.update k v bm) m"
definition lookup :: "'k::hashable ⇒ ('k,'v) hm_impl ⇒ 'v option" where
"lookup k m ==
case rm.lookup (hashcode k) m of
None ⇒ None |
Some lm ⇒ lm.lookup k lm"
definition delete :: "'k::hashable ⇒ ('k,'v) hm_impl ⇒ ('k,'v) hm_impl" where
"delete k m ==
rm_map_entry (hashcode k)
(λv. case v of
None ⇒ None |
Some lm ⇒ (
let lm' = lm.delete k lm
in if lm.isEmpty lm' then None else Some lm'
)
) m"
definition "isEmpty == rm.isEmpty"
definition "iteratei m c f σ0 ==
rm.iteratei m c (λ(hc, lm) σ.
lm.iteratei lm c f σ
) σ0"
lemma iteratei_alt_def :
"iteratei m = set_iterator_image snd (
set_iterator_product (rm.iteratei m) (λhclm. lm.iteratei (snd hclm)))"
proof -
have aux: "⋀c f. (λ(hc, lm). lm.iteratei lm c f) = (λm. lm.iteratei (snd m) c f)"
by auto
show ?thesis
unfolding set_iterator_product_def set_iterator_image_alt_def
iteratei_def[abs_def] aux
by (simp add: split_beta)
qed
subsubsection "Correctness w.r.t. Abstract HashMap"
text ‹
The following lemmas establish the correctness of the operations w.r.t. the
abstract hashmap.
They have the naming scheme op\_correct', where (is) the name of the
operation.
›
definition hm_α' where "hm_α' m == λhc. case rm.α m hc of
None ⇒ None |
Some lm ⇒ Some (lm.α lm)"
definition "invar m == ahm_invar (hm_α' m)"
lemma rm_map_entry_correct:
"rm.α (rm_map_entry k f m) = (rm.α m)(k := f (rm.α m k))"
apply (auto
simp add: rm_map_entry_def rm.delete_correct rm.lookup_correct rm.update_correct
split: option.split)
done
lemma empty_correct':
"hm_α' (empty ()) = ahm_empty"
"invar (empty ())"
by (simp_all add: hm_α'_def empty_def ahm_empty_def rm.correct invar_def ahm_invar_def)
lemma lookup_correct':
"invar m ⟹ lookup k m = ahm_lookup k (hm_α' m)"
apply (unfold lookup_def invar_def)
apply (auto split: option.split
simp add: ahm_lookup_def ahm_α_def hm_α'_def
rm.correct lm.correct)
done
lemma update_correct':
"invar m ⟹ hm_α' (update k v m) = ahm_update k v (hm_α' m)"
"invar m ⟹ invar (update k v m)"
proof -
assume "invar m"
thus "hm_α' (update k v m) = ahm_update k v (hm_α' m)"
apply (unfold invar_def)
apply (rule ext)
apply (auto simp add: update_def ahm_update_def hm_α'_def Let_def
rm.correct lm.correct
split: option.split)
done
thus "invar m ⟹ invar (update k v m)"
by (simp add: invar_def ahm_update_correct)
qed
lemma delete_correct':
"invar m ⟹ hm_α' (delete k m) = ahm_delete k (hm_α' m)"
"invar m ⟹ invar (delete k m)"
proof -
assume "invar m"
thus "hm_α' (delete k m) = ahm_delete k (hm_α' m)"
apply (unfold invar_def)
apply (rule ext)
apply (auto simp add: delete_def ahm_delete_def hm_α'_def
rm_map_entry_correct
rm.correct lm.correct Let_def
split: option.split option.split_asm)
done
thus "invar (delete k m)" using ‹invar m›
by (simp add: ahm_delete_correct invar_def)
qed
lemma isEmpty_correct':
"invar hm ⟹ isEmpty hm ⟷ ahm_α (hm_α' hm) = Map.empty"
apply (simp add: isEmpty_def rm.isEmpty_correct invar_def
ahm_isEmpty_correct[unfolded ahm_isEmpty_def, symmetric])
by (auto simp add: hm_α'_def ahm_α_def fun_eq_iff split: option.split_asm)
lemma iteratei_correct':
assumes invar: "invar hm"
shows "map_iterator (iteratei hm) (ahm_α (hm_α' hm))"
proof -
from rm.iteratei_correct
have it_rm: "map_iterator (rm.iteratei hm) (rm.α hm)" by simp
from lm.iteratei_correct
have it_lm: "⋀lm. map_iterator (lm.iteratei lm) (lm.α lm)" by simp
from set_iterator_product_correct
[OF it_rm, of "λhclm. lm.iteratei (snd hclm)"
"λhclm. map_to_set (lm.α (snd hclm))", OF it_lm]
have it_prod: "set_iterator
(set_iterator_product (rm.iteratei hm) (λhclm. lm.iteratei (snd hclm)))
(SIGMA hclm:map_to_set (rm.α hm). map_to_set (lm.α (snd hclm)))"
by simp
show ?thesis unfolding iteratei_alt_def
proof (rule set_iterator_image_correct[OF it_prod])
from invar
show "inj_on snd
(SIGMA hclm:map_to_set (rm.α hm). map_to_set (lm.α (snd hclm)))"
apply (simp add: inj_on_def invar_def ahm_invar_def hm_α'_def Ball_def
map_to_set_def split: option.splits)
apply (metis domI option.inject)
done
next
from invar
show "map_to_set (ahm_α (hm_α' hm)) =
snd ` (SIGMA hclm:map_to_set (rm.α hm). map_to_set (lm.α (snd hclm)))"
apply (simp add: inj_on_def invar_def ahm_invar_def hm_α'_def Ball_def
map_to_set_def set_eq_iff image_iff split: option.splits)
apply (auto simp add: dom_def ahm_α_def split: option.splits)
done
qed
qed
lemmas hm_correct' = empty_correct' lookup_correct' update_correct'
delete_correct' isEmpty_correct'
iteratei_correct'
lemmas hm_invars = empty_correct'(2) update_correct'(2)
delete_correct'(2)
hide_const (open) empty invar lookup update delete isEmpty iteratei
end
Theory HashMap
section ‹\isaheader{Hash Maps}›
theory HashMap
imports HashMap_Impl
begin
text_raw ‹\label{thy:HashMap}›
subsection "Type definition"
typedef (overloaded) ('k, 'v) hashmap = "{hm :: ('k :: hashable, 'v) hm_impl. HashMap_Impl.invar hm}"
morphisms impl_of_RBT_HM RBT_HM
proof
show "HashMap_Impl.empty () ∈ {hm. HashMap_Impl.invar hm}"
by(simp add: HashMap_Impl.empty_correct')
qed
lemma impl_of_RBT_HM_invar [simp, intro!]: "HashMap_Impl.invar (impl_of_RBT_HM hm)"
using impl_of_RBT_HM[of hm] by simp
lemma RBT_HM_imp_of_RBT_HM [code abstype]:
"RBT_HM (impl_of_RBT_HM hm) = hm"
by(fact impl_of_RBT_HM_inverse)
definition hm_empty_const :: "('k :: hashable, 'v) hashmap"
where "hm_empty_const = RBT_HM (HashMap_Impl.empty ())"
definition hm_empty :: "unit ⇒ ('k :: hashable, 'v) hashmap"
where "hm_empty = (λ_. hm_empty_const)"
definition "hm_lookup k hm == HashMap_Impl.lookup k (impl_of_RBT_HM hm)"
definition hm_update :: "('k :: hashable) ⇒ 'v ⇒ ('k, 'v) hashmap ⇒ ('k, 'v) hashmap"
where "hm_update k v hm = RBT_HM (HashMap_Impl.update k v (impl_of_RBT_HM hm))"
definition hm_update_dj :: "('k :: hashable) ⇒ 'v ⇒ ('k, 'v) hashmap ⇒ ('k, 'v) hashmap"
where "hm_update_dj = hm_update"
definition hm_delete :: "('k :: hashable) ⇒ ('k, 'v) hashmap ⇒ ('k, 'v) hashmap"
where "hm_delete k hm = RBT_HM (HashMap_Impl.delete k (impl_of_RBT_HM hm))"
definition hm_isEmpty :: "('k :: hashable, 'v) hashmap ⇒ bool"
where "hm_isEmpty hm = HashMap_Impl.isEmpty (impl_of_RBT_HM hm)"
definition "hm_iteratei hm == HashMap_Impl.iteratei (impl_of_RBT_HM hm)"
lemma impl_of_hm_empty [simp, code abstract]:
"impl_of_RBT_HM (hm_empty_const) = HashMap_Impl.empty ()"
by(simp add: hm_empty_const_def empty_correct' RBT_HM_inverse)
lemma impl_of_hm_update [simp, code abstract]:
"impl_of_RBT_HM (hm_update k v hm) = HashMap_Impl.update k v (impl_of_RBT_HM hm)"
by(simp add: hm_update_def update_correct' RBT_HM_inverse)
lemma impl_of_hm_delete [simp, code abstract]:
"impl_of_RBT_HM (hm_delete k hm) = HashMap_Impl.delete k (impl_of_RBT_HM hm)"
by(simp add: hm_delete_def delete_correct' RBT_HM_inverse)
subsection "Correctness w.r.t. Map"
text ‹
The next lemmas establish the correctness of the hashmap operations w.r.t. the
associated map. This is achieved by chaining the correctness lemmas of the
concrete hashmap w.r.t. the abstract hashmap and the correctness lemmas of the
abstract hashmap w.r.t. maps.
›
type_synonym ('k, 'v) hm = "('k, 'v) hashmap"
definition "hm_α == ahm_α ∘ hm_α' ∘ impl_of_RBT_HM"
abbreviation (input) hm_invar :: "('k :: hashable, 'v) hashmap ⇒ bool"
where "hm_invar == λ_. True"
lemma hm_aux_correct:
"hm_α (hm_empty ()) = Map.empty "
"hm_lookup k m = hm_α m k"
"hm_α (hm_update k v m) = (hm_α m)(k↦v)"
"hm_α (hm_delete k m) = (hm_α m) |` (-{k})"
by(auto simp add: hm_α_def hm_correct' hm_empty_def ahm_correct hm_lookup_def)
lemma hm_finite[simp, intro!]:
"finite (dom (hm_α m))"
proof(cases m)
case (RBT_HM m')
hence SS: "dom (hm_α m) ⊆ ⋃{ dom (lm.α lm) | lm hc. rm.α m' hc = Some lm }"
apply(clarsimp simp add: RBT_HM_inverse hm_α_def hm_α'_def [abs_def] ahm_α_def [abs_def])
apply(auto split: option.split_asm option.split)
done
moreover have "finite …" (is "finite (⋃?A)")
proof
have "{ dom (lm.α lm) | lm hc. rm.α m' hc = Some lm }
⊆ (λhc. dom (lm.α (the (rm.α m' hc)) )) ` (dom (rm.α m'))"
(is "?S ⊆ _")
by force
thus "finite ?A" by(rule finite_subset) auto
next
fix M
assume "M ∈ ?A"
thus "finite M" by auto
qed
ultimately show ?thesis unfolding RBT_HM by(rule finite_subset)
qed
lemma hm_iteratei_impl:
"map_iterator (hm_iteratei m) (hm_α m)"
apply (unfold hm_α_def hm_iteratei_def o_def)
apply(rule iteratei_correct'[OF impl_of_RBT_HM_invar])
done
subsection "Integration in Isabelle Collections Framework"
text ‹
In this section, we integrate hashmaps into the Isabelle Collections Framework.
›
definition [icf_rec_def]: "hm_basic_ops ≡ ⦇
bmap_op_α = hm_α,
bmap_op_invar = λ_. True,
bmap_op_empty = hm_empty,
bmap_op_lookup = hm_lookup,
bmap_op_update = hm_update,
bmap_op_update_dj = hm_update,
bmap_op_delete = hm_delete,
bmap_op_list_it = hm_iteratei
⦈"
setup Locale_Code.open_block
interpretation hm_basic: StdBasicMap hm_basic_ops
apply unfold_locales
apply (simp_all add: icf_rec_unf hm_aux_correct hm_iteratei_impl)
done
setup Locale_Code.close_block
definition [icf_rec_def]: "hm_ops ≡ hm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation hm: StdMapDefs hm_ops .
interpretation hm: StdMap hm_ops
unfolding hm_ops_def
by (rule hm_basic.dflt_ops_impl)
interpretation hm: StdMap_no_invar hm_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "hm"›
lemma pi_hm[proper_it]:
shows "proper_it' hm_iteratei hm_iteratei"
apply (rule proper_it'I)
unfolding hm_iteratei_def HashMap_Impl.iteratei_alt_def
by (intro icf_proper_iteratorI)
interpretation pi_hm: proper_it_loc hm_iteratei hm_iteratei
apply unfold_locales
apply (rule pi_hm)
done
text ‹Code generator test›
definition test_codegen where "test_codegen ≡ (
hm.add ,
hm.add_dj ,
hm.ball ,
hm.bex ,
hm.delete ,
hm.empty ,
hm.isEmpty ,
hm.isSng ,
hm.iterate ,
hm.iteratei ,
hm.list_it ,
hm.lookup ,
hm.restrict ,
hm.sel ,
hm.size ,
hm.size_abort ,
hm.sng ,
hm.to_list ,
hm.to_map ,
hm.update ,
hm.update_dj)"
export_code test_codegen checking SML
end
Theory Trie_Impl
section ‹\isaheader{Implementation of a trie with explicit invariants}›
theory Trie_Impl imports
"../../Lib/Assoc_List"
Trie.Trie
begin
subsection ‹Interuptible iterator›
fun iteratei_postfixed :: "'key list ⇒ ('key, 'val) trie ⇒
('key list × 'val, 'σ) set_iterator"
where
"iteratei_postfixed ks (Trie vo ts) c f σ =
(if c σ
then foldli ts c (λ(k, t) σ. iteratei_postfixed (k # ks) t c f σ)
(case vo of None ⇒ σ | Some v ⇒ f (ks, v) σ)
else σ)"
definition iteratei :: "('key, 'val) trie ⇒ ('key list × 'val, 'σ) set_iterator"
where "iteratei t c f σ = iteratei_postfixed [] t c f σ"
lemma iteratei_postfixed_interrupt:
"¬ c σ ⟹ iteratei_postfixed ks t c f σ = σ"
by(cases t) simp
lemma iteratei_interrupt:
"¬ c σ ⟹ iteratei t c f σ = σ"
unfolding iteratei_def by (simp add: iteratei_postfixed_interrupt)
lemma iteratei_postfixed_alt_def :
"iteratei_postfixed ks ((Trie vo ts)::('key, 'val) trie) =
(set_iterator_union
(case_option set_iterator_emp (λv. set_iterator_sng (ks, v)) vo)
(set_iterator_image snd
(set_iterator_product (foldli ts)
(λ(k, t'). iteratei_postfixed (k # ks) t'))
))"
proof -
have aux: "⋀c f. (λ(k, t). iteratei_postfixed (k # ks) t c f) =
(λa. iteratei_postfixed (fst a # ks) (snd a) c f)"
by auto
show ?thesis
apply (rule ext)+ apply (rename_tac c f σ)
apply (simp add: set_iterator_product_def set_iterator_image_filter_def
set_iterator_union_def set_iterator_sng_def set_iterator_image_alt_def
case_prod_beta set_iterator_emp_def
split: option.splits)
apply (simp add: aux)
done
qed
lemma iteratei_postfixed_correct :
assumes invar: "invar_trie (t :: ('key, 'val) trie)"
shows "set_iterator ((iteratei_postfixed ks0 t)::('key list × 'val, 'σ) set_iterator)
((λksv. (rev (fst ksv) @ ks0, (snd ksv))) ` (map_to_set (lookup_trie t)))"
using invar
proof (induct t arbitrary: ks0)
case (Trie vo kvs)
note ind_hyp = Trie(1)
note invar = Trie(2)
from invar
have dist_fst_kvs : "distinct (map fst kvs)"
and dist_kvs: "distinct kvs"
and invar_child: "⋀k t. (k, t) ∈ set kvs ⟹ invar_trie t"
by (simp_all add: Ball_def distinct_map)
define it_vo :: "('key list × 'val, 'σ) set_iterator"
where "it_vo =
(case vo of None ⇒ set_iterator_emp
| Some v ⇒ set_iterator_sng (ks0, v))"
define vo_S where "vo_S = (case vo of None ⇒ {} | Some v ⇒ {(ks0, v)})"
have it_vo_OK: "set_iterator it_vo vo_S"
unfolding it_vo_def vo_S_def
by (simp split: option.split
add: set_iterator_emp_correct set_iterator_sng_correct)
define it_prod :: "(('key × ('key, 'val) trie) × 'key list × 'val, 'σ) set_iterator"
where "it_prod = set_iterator_product (foldli kvs) (λ(k, y). iteratei_postfixed (k # ks0) y)"
define it_prod_S where "it_prod_S = (SIGMA kt:set kvs.
(λksv. (rev (fst ksv) @ ((fst kt) # ks0), snd ksv)) `
map_to_set (lookup_trie (snd kt)))"
have it_prod_OK: "set_iterator it_prod it_prod_S"
proof -
from set_iterator_foldli_correct[OF dist_kvs]
have it_foldli: "set_iterator (foldli kvs) (set kvs)" .
{ fix kt
assume kt_in: "kt ∈ set kvs"
hence k_t_in: "(fst kt, snd kt) ∈ set kvs" by simp
note ind_hyp [OF k_t_in, OF invar_child[OF k_t_in], of "fst kt # ks0"]
} note it_child = this
show ?thesis
unfolding it_prod_def it_prod_S_def
apply (rule set_iterator_product_correct [OF it_foldli])
apply (insert it_child)
apply (simp add: case_prod_beta)
done
qed
have it_image_OK : "set_iterator (set_iterator_image snd it_prod) (snd ` it_prod_S)"
proof (rule set_iterator_image_correct[OF it_prod_OK])
from dist_fst_kvs
have "⋀k v1 v2. (k, v1) ∈ set kvs ⟹ (k, v2) ∈ set kvs ⟹ v1 = v2"
by (induct kvs) (auto simp add: image_iff)
thus "inj_on snd it_prod_S"
unfolding inj_on_def it_prod_S_def
apply (simp add: image_iff Ball_def map_to_set_def)
apply auto
done
qed auto
have it_all_OK: "set_iterator
((iteratei_postfixed ks0 (Trie vo kvs)):: ('key list × 'val, 'σ) set_iterator)
(vo_S ∪ snd ` it_prod_S)"
unfolding iteratei_postfixed_alt_def
it_vo_def[symmetric]
it_prod_def[symmetric]
proof (rule set_iterator_union_correct [OF it_vo_OK it_image_OK])
show "vo_S ∩ snd ` it_prod_S = {}"
unfolding vo_S_def it_prod_S_def
by (simp split: option.split add: set_eq_iff image_iff)
qed
have it_set_rewr: "((λksv. (rev (fst ksv) @ ks0, snd ksv)) `
map_to_set (lookup_trie (Trie vo kvs))) = (vo_S ∪ snd ` it_prod_S)"
(is "?ls = ?rs")
apply (simp add: map_to_set_def lookup_eq_Some_iff[OF invar]
set_eq_iff image_iff vo_S_def it_prod_S_def Ball_def Bex_def)
apply (simp split: option.split del: ex_simps add: ex_simps[symmetric])
apply (intro allI impI iffI)
apply auto[]
apply (metis append_Cons append_Nil append_assoc rev.simps)
done
show ?case
unfolding it_set_rewr using it_all_OK by fast
qed
definition trie_reverse_key where
"trie_reverse_key ksv = (rev (fst ksv), (snd ksv))"
lemma trie_reverse_key_alt_def[code] :
"trie_reverse_key (ks, v) = (rev ks, v)"
unfolding trie_reverse_key_def by auto
lemma trie_reverse_key_reverse[simp] :
"trie_reverse_key (trie_reverse_key ksv) = ksv"
by (simp add: trie_reverse_key_def)
lemma trie_iteratei_correct:
assumes invar: "invar_trie (t :: ('key, 'val) trie)"
shows "set_iterator ((iteratei t)::('key list × 'val, 'σ) set_iterator)
(trie_reverse_key ` (map_to_set (lookup_trie t)))"
unfolding trie_reverse_key_def[abs_def] iteratei_def[abs_def]
using iteratei_postfixed_correct [OF invar, of "[]"]
by simp
hide_const (open) iteratei
hide_type (open) trie
end
Theory Trie2
section ‹\isaheader{Tries without invariants}›
theory Trie2 imports
Trie_Impl
begin
lemma rev_rev_image: "rev ` rev ` A = A"
by(auto intro: rev_image_eqI[where x="rev y" for y])
subsection ‹Abstract type definition›
typedef ('key, 'val) trie =
"{t :: ('key, 'val) Trie.trie. invar_trie t}"
morphisms impl_of Trie
proof
show "empty_trie ∈ ?trie" by(simp)
qed
lemma invar_trie_impl_of [simp, intro]: "invar_trie (impl_of t)"
using impl_of[of t] by simp
lemma Trie_impl_of [code abstype]: "Trie (impl_of t) = t"
by(rule impl_of_inverse)
subsection ‹Primitive operations›
definition empty :: "('key, 'val) trie"
where "empty = Trie (empty_trie)"
definition update :: "'key list ⇒ 'val ⇒ ('key, 'val) trie ⇒ ('key, 'val) trie"
where "update ks v t = Trie (update_trie ks v (impl_of t))"
definition delete :: "'key list ⇒ ('key, 'val) trie ⇒ ('key, 'val) trie"
where "delete ks t = Trie (delete_trie ks (impl_of t))"
definition lookup :: "('key, 'val) trie ⇒ 'key list ⇒ 'val option"
where "lookup t = lookup_trie (impl_of t)"
definition isEmpty :: "('key, 'val) trie ⇒ bool"
where "isEmpty t = is_empty_trie (impl_of t)"
definition iteratei :: "('key, 'val) trie ⇒ ('key list × 'val, 'σ) set_iterator"
where "iteratei t = set_iterator_image trie_reverse_key (Trie_Impl.iteratei (impl_of t))"
lemma iteratei_code[code] :
"iteratei t c f = Trie_Impl.iteratei (impl_of t) c (λ(ks, v). f (rev ks, v))"
unfolding iteratei_def set_iterator_image_alt_def
apply (subgoal_tac "(λx. f (trie_reverse_key x)) = (λ(ks, v). f (rev ks, v))")
apply (auto simp add: trie_reverse_key_def)
done
lemma impl_of_empty [code abstract]: "impl_of empty = empty_trie"
by(simp add: empty_def Trie_inverse)
lemma impl_of_update [code abstract]: "impl_of (update ks v t) = update_trie ks v (impl_of t)"
by(simp add: update_def Trie_inverse invar_trie_update)
lemma impl_of_delete [code abstract]: "impl_of (delete ks t) = delete_trie ks (impl_of t)"
by(simp add: delete_def Trie_inverse invar_trie_delete)
subsection ‹Correctness of primitive operations›
lemma lookup_empty [simp]: "lookup empty = Map.empty"
by(simp add: lookup_def empty_def Trie_inverse)
lemma lookup_update [simp]: "lookup (update ks v t) = (lookup t)(ks ↦ v)"
by(simp add: lookup_def update_def Trie_inverse invar_trie_update lookup_update')
lemma lookup_delete [simp]: "lookup (delete ks t) = (lookup t)(ks := None)"
by(simp add: lookup_def delete_def Trie_inverse invar_trie_delete lookup_delete')
lemma isEmpty_lookup: "isEmpty t ⟷ lookup t = Map.empty"
by(simp add: isEmpty_def lookup_def is_empty_lookup_empty)
lemma finite_dom_lookup: "finite (dom (lookup t))"
by(simp add: lookup_def finite_dom_lookup)
lemma iteratei_correct:
"map_iterator (iteratei m) (lookup m)"
proof -
note it_base = Trie_Impl.trie_iteratei_correct [of "impl_of m"]
show ?thesis
unfolding iteratei_def lookup_def
apply (rule set_iterator_image_correct [OF it_base])
apply (simp_all add: set_eq_iff image_iff inj_on_def)
done
qed
subsection ‹Type classes›
instantiation trie :: (equal, equal) equal begin
definition "equal_class.equal (t :: ('a, 'b) trie) t' = (impl_of t = impl_of t')"
instance
proof
qed(simp add: equal_trie_def impl_of_inject)
end
hide_const (open) empty lookup update delete iteratei isEmpty
end
Theory TrieMapImpl
section ‹\isaheader{Map implementation via tries}›
theory TrieMapImpl imports
Trie2
"../gen_algo/MapGA"
begin
subsection ‹Operations›
type_synonym ('k, 'v) tm = "('k, 'v) trie"
definition [icf_rec_def]: "tm_basic_ops ≡ ⦇
bmap_op_α = Trie2.lookup,
bmap_op_invar = λ_. True,
bmap_op_empty = (λ_::unit. Trie2.empty),
bmap_op_lookup = (λk m. Trie2.lookup m k),
bmap_op_update = Trie2.update,
bmap_op_update_dj = Trie2.update,
bmap_op_delete = Trie2.delete,
bmap_op_list_it = Trie2.iteratei
⦈"
setup Locale_Code.open_block
interpretation tm_basic: StdBasicMap tm_basic_ops
apply unfold_locales
apply (simp_all
add: icf_rec_unf Trie2.finite_dom_lookup Trie2.iteratei_correct
add: map_upd_eq_restrict)
done
setup Locale_Code.close_block
definition [icf_rec_def]: "tm_ops ≡ tm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation tm: StdMap tm_ops
unfolding tm_ops_def
by (rule tm_basic.dflt_ops_impl)
interpretation tm: StdMap_no_invar tm_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "tm"›
lemma pi_trie_impl[proper_it]:
shows "proper_it'
((Trie_Impl.iteratei) :: _ ⇒ (_,'σa) set_iterator)
((Trie_Impl.iteratei) :: _ ⇒ (_,'σb) set_iterator)"
unfolding Trie_Impl.iteratei_def[abs_def]
proof (rule proper_it'I)
fix t :: "('k,'v) Trie.trie"
{
fix l and t :: "('k,'v) Trie.trie"
have "proper_it ((Trie_Impl.iteratei_postfixed l t)
:: (_,'σa) set_iterator)
((Trie_Impl.iteratei_postfixed l t)
:: (_,'σb) set_iterator)"
proof (induct t arbitrary: l)
case (Trie vo kvs l)
let ?ITA = "λl t. (Trie_Impl.iteratei_postfixed l t)
:: (_,'σa) set_iterator"
let ?ITB = "λl t. (Trie_Impl.iteratei_postfixed l t)
:: (_,'σb) set_iterator"
show ?case
unfolding Trie_Impl.iteratei_postfixed_alt_def
apply (rule pi_union)
apply (auto split: option.split intro: icf_proper_iteratorI) []
proof (rule pi_image)
define bs where "bs = (λ(k,t). SOME l'::('k list × 'v) list.
?ITA (k#l) t = foldli l' ∧ ?ITB (k#l) t = foldli l')"
have EQ1: "∀(k,t)∈set kvs. ?ITA (k#l) t = foldli (bs (k,t))" and
EQ2: "∀(k,t)∈set kvs. ?ITB (k#l) t = foldli (bs (k,t))"
proof (safe)
fix k t
assume A: "(k,t) ∈ set kvs"
from Trie.hyps[OF A, of "k#l"] have
PI: "proper_it (?ITA (k#l) t) (?ITB (k#l) t)"
by assumption
obtain l' where
"?ITA (k#l) t = foldli l'
∧ (?ITB (k#l) t) = foldli l'"
by (blast intro: proper_itE[OF PI])
thus "?ITA (k#l) t = foldli (bs (k,t))"
"?ITB (k#l) t = foldli (bs (k,t))"
unfolding bs_def
apply auto
apply (metis (lifting, full_types) someI_ex)
apply (metis (lifting, full_types) someI_ex)
done
qed
have PEQ1: "set_iterator_product (foldli kvs) (λ(k,t). ?ITA (k#l) t)
= set_iterator_product (foldli kvs) (λkt. foldli (bs kt))"
apply (rule set_iterator_product_eq2)
using EQ1 by auto
have PEQ2: "set_iterator_product (foldli kvs) (λ(k,t). ?ITB (k#l) t)
= set_iterator_product (foldli kvs) (λkt. foldli (bs kt))"
apply (rule set_iterator_product_eq2)
using EQ2 by auto
show "proper_it
(set_iterator_product (foldli kvs) (λ(k,t). ?ITA (k#l) t))
(set_iterator_product (foldli kvs) (λ(k,t). ?ITB (k#l) t))"
apply (subst PEQ1)
apply (subst PEQ2)
apply (auto simp: set_iterator_product_foldli_conv)
by (blast intro: proper_itI)
qed
qed
} thus "proper_it
(iteratei_postfixed [] t :: (_,'σa) set_iterator)
(iteratei_postfixed [] t :: (_,'σb) set_iterator)" .
qed
lemma pi_trie[proper_it]:
"proper_it' Trie2.iteratei Trie2.iteratei"
unfolding Trie2.iteratei_def[abs_def]
apply (rule proper_it'I)
apply (intro icf_proper_iteratorI)
apply (rule proper_it'D)
by (rule pi_trie_impl)
interpretation pi_trie: proper_it_loc Trie2.iteratei Trie2.iteratei
apply unfold_locales
apply (rule pi_trie)
done
text ‹Code generator test›
definition "test_codegen ≡ (
tm.add ,
tm.add_dj ,
tm.ball ,
tm.bex ,
tm.delete ,
tm.empty ,
tm.isEmpty ,
tm.isSng ,
tm.iterate ,
tm.iteratei ,
tm.list_it ,
tm.lookup ,
tm.restrict ,
tm.sel ,
tm.size ,
tm.size_abort ,
tm.sng ,
tm.to_list ,
tm.to_map ,
tm.update ,
tm.update_dj)"
export_code test_codegen checking SML
end
Theory ArrayHashMap_Impl
section ‹\isaheader{Array-based hash map implementation}›
theory ArrayHashMap_Impl imports
"../../Lib/HashCode"
"../../Lib/Code_Target_ICF"
"../../Lib/Diff_Array"
"../gen_algo/ListGA"
ListMapImpl
"../../Iterator/Array_Iterator"
begin
text ‹Misc.›
setup Locale_Code.open_block
interpretation a_idx_it:
idx_iteratei_loc list_of_array "λ_. True" array_length array_get
apply unfold_locales
apply (case_tac [!] s) [2]
apply auto
done
setup Locale_Code.close_block
subsection ‹Type definition and primitive operations›
definition load_factor :: nat
where "load_factor = 75"
text ‹
We do not use @{typ "('k, 'v) assoc_list"} for the buckets but plain lists of key-value pairs.
This speeds up rehashing because we then do not have to go through the abstract operations.
›
datatype ('key, 'val) hashmap =
HashMap "('key × 'val) list array" "nat"
subsection ‹Operations›
definition new_hashmap_with :: "nat ⇒ ('key :: hashable, 'val) hashmap"
where "⋀size. new_hashmap_with size = HashMap (new_array [] size) 0"
definition ahm_empty :: "unit ⇒ ('key :: hashable, 'val) hashmap"
where "ahm_empty ≡ λ_. new_hashmap_with (def_hashmap_size TYPE('key))"
definition bucket_ok :: "nat ⇒ nat ⇒ (('key :: hashable) × 'val) list ⇒ bool"
where "bucket_ok len h kvs = (∀k ∈ fst ` set kvs. bounded_hashcode_nat len k = h)"
definition ahm_invar_aux :: "nat ⇒ (('key :: hashable) × 'val) list array ⇒ bool"
where
"ahm_invar_aux n a ⟷
(∀h. h < array_length a ⟶ bucket_ok (array_length a) h (array_get a h) ∧ distinct (map fst (array_get a h))) ∧
array_foldl (λ_ n kvs. n + size kvs) 0 a = n ∧
array_length a > 1"
primrec ahm_invar :: "('key :: hashable, 'val) hashmap ⇒ bool"
where "ahm_invar (HashMap a n) = ahm_invar_aux n a"
definition ahm_α_aux :: "(('key :: hashable) × 'val) list array ⇒ 'key ⇒ 'val option"
where [simp]: "ahm_α_aux a k = map_of (array_get a (bounded_hashcode_nat (array_length a) k)) k"
primrec ahm_α :: "('key :: hashable, 'val) hashmap ⇒ 'key ⇒ 'val option"
where
"ahm_α (HashMap a _) = ahm_α_aux a"
definition ahm_lookup :: "'key ⇒ ('key :: hashable, 'val) hashmap ⇒ 'val option"
where "ahm_lookup k hm = ahm_α hm k"
primrec ahm_iteratei_aux :: "((('key :: hashable) × 'val) list array) ⇒ ('key × 'val, 'σ) set_iterator"
where "ahm_iteratei_aux (Array xs) c f = foldli (concat xs) c f"
primrec ahm_iteratei :: "(('key :: hashable, 'val) hashmap) ⇒ (('key × 'val), 'σ) set_iterator"
where
"ahm_iteratei (HashMap a n) = ahm_iteratei_aux a"
definition ahm_rehash_aux' :: "nat ⇒ 'key × 'val ⇒ (('key :: hashable) × 'val) list array ⇒ ('key × 'val) list array"
where
"ahm_rehash_aux' n kv a =
(let h = bounded_hashcode_nat n (fst kv)
in array_set a h (kv # array_get a h))"
definition ahm_rehash_aux :: "(('key :: hashable) × 'val) list array ⇒ nat ⇒ ('key × 'val) list array"
where
"ahm_rehash_aux a sz = ahm_iteratei_aux a (λx. True) (ahm_rehash_aux' sz) (new_array [] sz)"
primrec ahm_rehash :: "('key :: hashable, 'val) hashmap ⇒ nat ⇒ ('key, 'val) hashmap"
where "ahm_rehash (HashMap a n) sz = HashMap (ahm_rehash_aux a sz) n"
primrec hm_grow :: "('key :: hashable, 'val) hashmap ⇒ nat"
where "hm_grow (HashMap a n) = 2 * array_length a + 3"
primrec ahm_filled :: "('key :: hashable, 'val) hashmap ⇒ bool"
where "ahm_filled (HashMap a n) = (array_length a * load_factor ≤ n * 100)"
primrec ahm_update_aux :: "('key :: hashable, 'val) hashmap ⇒ 'key ⇒ 'val ⇒ ('key, 'val) hashmap"
where
"ahm_update_aux (HashMap a n) k v =
(let h = bounded_hashcode_nat (array_length a) k;
m = array_get a h;
insert = map_of m k = None
in HashMap (array_set a h (AList.update k v m)) (if insert then n + 1 else n))"
definition ahm_update :: "'key ⇒ 'val ⇒ ('key :: hashable, 'val) hashmap ⇒ ('key, 'val) hashmap"
where
"ahm_update k v hm =
(let hm' = ahm_update_aux hm k v
in (if ahm_filled hm' then ahm_rehash hm' (hm_grow hm') else hm'))"
primrec ahm_delete :: "'key ⇒ ('key :: hashable, 'val) hashmap ⇒ ('key, 'val) hashmap"
where
"ahm_delete k (HashMap a n) =
(let h = bounded_hashcode_nat (array_length a) k;
m = array_get a h;
deleted = (map_of m k ≠ None)
in HashMap (array_set a h (AList.delete k m)) (if deleted then n - 1 else n))"
lemma hm_grow_gt_1 [iff]:
"Suc 0 < hm_grow hm"
by(cases hm)(simp)
lemma bucket_ok_Nil [simp]: "bucket_ok len h [] = True"
by(simp add: bucket_ok_def)
lemma bucket_okD:
"⟦ bucket_ok len h xs; (k, v) ∈ set xs ⟧
⟹ bounded_hashcode_nat len k = h"
by(auto simp add: bucket_ok_def)
lemma bucket_okI:
"(⋀k. k ∈ fst ` set kvs ⟹ bounded_hashcode_nat len k = h) ⟹ bucket_ok len h kvs"
by(simp add: bucket_ok_def)
subsection ‹@{term ahm_invar}›
lemma ahm_invar_auxE:
assumes "ahm_invar_aux n a"
obtains "∀h. h < array_length a ⟶ bucket_ok (array_length a) h (array_get a h) ∧ distinct (map fst (array_get a h))"
and "n = array_foldl (λ_ n kvs. n + length kvs) 0 a" and "array_length a > 1"
using assms unfolding ahm_invar_aux_def by blast
lemma ahm_invar_auxI:
"⟦ ⋀h. h < array_length a ⟹ bucket_ok (array_length a) h (array_get a h);
⋀h. h < array_length a ⟹ distinct (map fst (array_get a h));
n = array_foldl (λ_ n kvs. n + length kvs) 0 a; array_length a > 1 ⟧
⟹ ahm_invar_aux n a"
unfolding ahm_invar_aux_def by blast
lemma ahm_invar_distinct_fst_concatD:
assumes inv: "ahm_invar_aux n (Array xs)"
shows "distinct (map fst (concat xs))"
proof -
{ fix h
assume "h < length xs"
with inv have "bucket_ok (length xs) h (xs ! h)" "distinct (map fst (xs ! h))"
by(simp_all add: ahm_invar_aux_def) }
note no_junk = this
show ?thesis unfolding map_concat
proof(rule distinct_concat')
have "distinct [x←xs . x ≠ []]" unfolding distinct_conv_nth
proof(intro allI ballI impI)
fix i j
assume "i < length [x←xs . x ≠ []]" "j < length [x←xs . x ≠ []]" "i ≠ j"
from filter_nth_ex_nth[OF ‹i < length [x←xs . x ≠ []]›]
obtain i' where "i' ≥ i" "i' < length xs" and ith: "[x←xs . x ≠ []] ! i = xs ! i'"
and eqi: "[x←take i' xs . x ≠ []] = take i [x←xs . x ≠ []]" by blast
from filter_nth_ex_nth[OF ‹j < length [x←xs . x ≠ []]›]
obtain j' where "j' ≥ j" "j' < length xs" and jth: "[x←xs . x ≠ []] ! j = xs ! j'"
and eqj: "[x←take j' xs . x ≠ []] = take j [x←xs . x ≠ []]" by blast
show "[x←xs . x ≠ []] ! i ≠ [x←xs . x ≠ []] ! j"
proof
assume "[x←xs . x ≠ []] ! i = [x←xs . x ≠ []] ! j"
hence eq: "xs ! i' = xs ! j'" using ith jth by simp
from ‹i < length [x←xs . x ≠ []]›
have "[x←xs . x ≠ []] ! i ∈ set [x←xs . x ≠ []]" by(rule nth_mem)
with ith have "xs ! i' ≠ []" by simp
then obtain kv where "kv ∈ set (xs ! i')" by(fastforce simp add: neq_Nil_conv)
with no_junk[OF ‹i' < length xs›] have "bounded_hashcode_nat (length xs) (fst kv) = i'"
by(simp add: bucket_ok_def)
moreover from eq ‹kv ∈ set (xs ! i')› have "kv ∈ set (xs ! j')" by simp
with no_junk[OF ‹j' < length xs›] have "bounded_hashcode_nat (length xs) (fst kv) = j'"
by(simp add: bucket_ok_def)
ultimately have [simp]: "i' = j'" by simp
from ‹i < length [x←xs . x ≠ []]› have "i = length (take i [x←xs . x ≠ []])" by simp
also from eqi eqj have "take i [x←xs . x ≠ []] = take j [x←xs . x ≠ []]" by simp
finally show False using ‹i ≠ j› ‹j < length [x←xs . x ≠ []]› by simp
qed
qed
moreover have "inj_on (map fst) {x ∈ set xs. x ≠ []}"
proof(rule inj_onI)
fix x y
assume "x ∈ {x ∈ set xs. x ≠ []}" "y ∈ {x ∈ set xs. x ≠ []}" "map fst x = map fst y"
hence "x ∈ set xs" "y ∈ set xs" "x ≠ []" "y ≠ []" by auto
from ‹x ∈ set xs› obtain i where "xs ! i = x" "i < length xs" unfolding set_conv_nth by fastforce
from ‹y ∈ set xs› obtain j where "xs ! j = y" "j < length xs" unfolding set_conv_nth by fastforce
from ‹x ≠ []› obtain k v x' where "x = (k, v) # x'" by(cases x) auto
with no_junk[OF ‹i < length xs›] ‹xs ! i = x›
have "bounded_hashcode_nat (length xs) k = i" by(auto simp add: bucket_ok_def)
moreover from ‹map fst x = map fst y› ‹x = (k, v) # x'› obtain v' where "(k, v') ∈ set y" by fastforce
with no_junk[OF ‹j < length xs›] ‹xs ! j = y›
have "bounded_hashcode_nat (length xs) k = j" by(auto simp add: bucket_ok_def)
ultimately have "i = j" by simp
with ‹xs ! i = x› ‹xs ! j = y› show "x = y" by simp
qed
ultimately show "distinct [ys←map (map fst) xs . ys ≠ []]"
by(simp add: filter_map o_def distinct_map)
next
fix ys
assume "ys ∈ set (map (map fst) xs)"
thus "distinct ys" by(clarsimp simp add: set_conv_nth)(rule no_junk)
next
fix ys zs
assume "ys ∈ set (map (map fst) xs)" "zs ∈ set (map (map fst) xs)" "ys ≠ zs"
then obtain ys' zs' where [simp]: "ys = map fst ys'" "zs = map fst zs'"
and "ys' ∈ set xs" "zs' ∈ set xs" by auto
have "fst ` set ys' ∩ fst ` set zs' = {}"
proof(rule equals0I)
fix k
assume "k ∈ fst ` set ys' ∩ fst ` set zs'"
then obtain v v' where "(k, v) ∈ set ys'" "(k, v') ∈ set zs'" by(auto)
from ‹ys' ∈ set xs› obtain i where "xs ! i = ys'" "i < length xs" unfolding set_conv_nth by fastforce
with ‹(k, v) ∈ set ys'› have "bounded_hashcode_nat (length xs) k = i" by(auto dest: no_junk bucket_okD)
moreover
from ‹zs' ∈ set xs› obtain j where "xs ! j = zs'" "j < length xs" unfolding set_conv_nth by fastforce
with ‹(k, v') ∈ set zs'› have "bounded_hashcode_nat (length xs) k = j" by(auto dest: no_junk bucket_okD)
ultimately have "i = j" by simp
with ‹xs ! i = ys'› ‹xs ! j = zs'› have "ys' = zs'" by simp
with ‹ys ≠ zs› show False by simp
qed
thus "set ys ∩ set zs = {}" by simp
qed
qed
subsection ‹@{term "ahm_α"}›
lemma finite_dom_ahm_α_aux:
assumes "ahm_invar_aux n a"
shows "finite (dom (ahm_α_aux a))"
proof -
have "dom (ahm_α_aux a) ⊆ (⋃h ∈ range (bounded_hashcode_nat (array_length a) :: 'a ⇒ nat). dom (map_of (array_get a h)))"
by(force simp add: dom_map_of_conv_image_fst ahm_α_aux_def dest: map_of_SomeD)
moreover have "finite …"
proof(rule finite_UN_I)
from ‹ahm_invar_aux n a› have "array_length a > 1" by(simp add: ahm_invar_aux_def)
hence "range (bounded_hashcode_nat (array_length a) :: 'a ⇒ nat) ⊆ {0..<array_length a}"
by(auto simp add: bounded_hashcode_nat_bounds)
thus "finite (range (bounded_hashcode_nat (array_length a) :: 'a ⇒ nat))"
by(rule finite_subset) simp
qed(rule finite_dom_map_of)
ultimately show ?thesis by(rule finite_subset)
qed
lemma ahm_α_aux_conv_map_of_concat:
assumes inv: "ahm_invar_aux n (Array xs)"
shows "ahm_α_aux (Array xs) = map_of (concat xs)"
proof
fix k
show "ahm_α_aux (Array xs) k = map_of (concat xs) k"
proof(cases "map_of (concat xs) k")
case None
hence "k ∉ fst ` set (concat xs)" by(simp add: map_of_eq_None_iff)
hence "k ∉ fst ` set (xs ! bounded_hashcode_nat (length xs) k)"
proof(rule contrapos_nn)
assume "k ∈ fst ` set (xs ! bounded_hashcode_nat (length xs) k)"
then obtain v where "(k, v) ∈ set (xs ! bounded_hashcode_nat (length xs) k)" by auto
moreover from inv have "bounded_hashcode_nat (length xs) k < length xs"
by(simp add: bounded_hashcode_nat_bounds ahm_invar_aux_def)
ultimately show "k ∈ fst ` set (concat xs)"
by(force intro: rev_image_eqI)
qed
thus ?thesis unfolding None by(simp add: map_of_eq_None_iff)
next
case (Some v)
hence "(k, v) ∈ set (concat xs)" by(rule map_of_SomeD)
then obtain ys where "ys ∈ set xs" "(k, v) ∈ set ys"
unfolding set_concat by blast
from ‹ys ∈ set xs› obtain i j where "i < length xs" "xs ! i = ys"
unfolding set_conv_nth by auto
with inv ‹(k, v) ∈ set ys›
show ?thesis unfolding Some
by(force dest: bucket_okD simp add: ahm_invar_aux_def)
qed
qed
lemma ahm_invar_aux_card_dom_ahm_α_auxD:
assumes inv: "ahm_invar_aux n a"
shows "card (dom (ahm_α_aux a)) = n"
proof(cases a)
case [simp]: (Array xs)
from inv have "card (dom (ahm_α_aux (Array xs))) = card (dom (map_of (concat xs)))"
by(simp add: ahm_α_aux_conv_map_of_concat)
also from inv have "distinct (map fst (concat xs))"
by(simp add: ahm_invar_distinct_fst_concatD)
hence "card (dom (map_of (concat xs))) = length (concat xs)"
by(rule card_dom_map_of)
also have "length (concat xs) = foldl (+) 0 (map length xs)"
by (simp add: length_concat foldl_conv_fold add.commute fold_plus_sum_list_rev)
also from inv
have "… = n" unfolding foldl_map by(simp add: ahm_invar_aux_def array_foldl_foldl)
finally show ?thesis by(simp)
qed
lemma finite_dom_ahm_α:
"ahm_invar hm ⟹ finite (dom (ahm_α hm))"
by(cases hm)(auto intro: finite_dom_ahm_α_aux)
lemma finite_map_ahm_α_aux:
"finite_map ahm_α_aux (ahm_invar_aux n)"
by(unfold_locales)(rule finite_dom_ahm_α_aux)
lemma finite_map_ahm_α:
"finite_map ahm_α ahm_invar"
by(unfold_locales)(rule finite_dom_ahm_α)
subsection ‹@{term ahm_empty}›
lemma ahm_invar_aux_new_array:
assumes "n > 1"
shows "ahm_invar_aux 0 (new_array [] n)"
proof -
have "foldl (λb (k, v). b + length v) 0 (zip [0..<n] (replicate n [])) = 0"
by(induct n)(simp_all add: replicate_Suc_conv_snoc del: replicate_Suc)
with assms show ?thesis by(simp add: ahm_invar_aux_def array_foldl_new_array)
qed
lemma ahm_invar_new_hashmap_with:
"n > 1 ⟹ ahm_invar (new_hashmap_with n)"
by(auto simp add: ahm_invar_def new_hashmap_with_def intro: ahm_invar_aux_new_array)
lemma ahm_α_new_hashmap_with:
"n > 1 ⟹ ahm_α (new_hashmap_with n) = Map.empty"
by(simp add: new_hashmap_with_def bounded_hashcode_nat_bounds fun_eq_iff)
lemma ahm_invar_ahm_empty [simp]: "ahm_invar (ahm_empty ())"
using def_hashmap_size[where ?'a = 'a]
by(auto intro: ahm_invar_new_hashmap_with simp add: ahm_empty_def)
lemma ahm_empty_correct [simp]: "ahm_α (ahm_empty ()) = Map.empty"
using def_hashmap_size[where ?'a = 'a]
by(auto intro: ahm_α_new_hashmap_with simp add: ahm_empty_def)
lemma ahm_empty_impl: "map_empty ahm_α ahm_invar ahm_empty"
by(unfold_locales)(auto)
subsection ‹@{term "ahm_lookup"}›
lemma ahm_lookup_impl: "map_lookup ahm_α ahm_invar ahm_lookup"
by(unfold_locales)(simp add: ahm_lookup_def)
subsection ‹@{term "ahm_iteratei"}›
lemma ahm_iteratei_aux_impl:
assumes invar_m: "ahm_invar_aux n m"
shows "map_iterator (ahm_iteratei_aux m) (ahm_α_aux m)"
proof -
obtain ms where m_eq[simp]: "m = Array ms" by (cases m)
from ahm_invar_distinct_fst_concatD[of n ms] invar_m
have dist: "distinct (map fst (concat ms))" by simp
show "map_iterator (ahm_iteratei_aux m) (ahm_α_aux m)"
using set_iterator_foldli_correct[of "concat ms"] dist
by (simp add: ahm_α_aux_conv_map_of_concat[OF invar_m[unfolded m_eq]]
ahm_iteratei_aux_def map_to_set_map_of[OF dist] distinct_map)
qed
lemma ahm_iteratei_correct:
assumes invar_hm: "ahm_invar hm"
shows "map_iterator (ahm_iteratei hm) (ahm_α hm)"
proof -
obtain A n where hm_eq [simp]: "hm = HashMap A n" by(cases hm)
from ahm_iteratei_aux_impl[of n A] invar_hm
show map_it: "map_iterator (ahm_iteratei hm) (ahm_α hm)" by simp
qed
lemma ahm_iteratei_aux_code [code]:
"ahm_iteratei_aux a c f σ = a_idx_it.idx_iteratei a c (λx. foldli x c f) σ"
proof(cases a)
case [simp]: (Array xs)
have "ahm_iteratei_aux a c f σ = foldli (concat xs) c f σ" by simp
also have "… = foldli xs c (λx. foldli x c f) σ" by (simp add: foldli_concat)
thm a_idx_it.idx_iteratei_correct
also have "… = a_idx_it.idx_iteratei a c (λx. foldli x c f) σ"
by (simp add: a_idx_it.idx_iteratei_correct)
finally show ?thesis .
qed
subsection ‹@{term "ahm_rehash"}›
lemma array_length_ahm_rehash_aux':
"array_length (ahm_rehash_aux' n kv a) = array_length a"
by(simp add: ahm_rehash_aux'_def Let_def)
lemma ahm_rehash_aux'_preserves_ahm_invar_aux:
assumes inv: "ahm_invar_aux n a"
and fresh: "k ∉ fst ` set (array_get a (bounded_hashcode_nat (array_length a) k))"
shows "ahm_invar_aux (Suc n) (ahm_rehash_aux' (array_length a) (k, v) a)"
(is "ahm_invar_aux _ ?a")
proof(rule ahm_invar_auxI)
fix h
assume "h < array_length ?a"
hence hlen: "h < array_length a" by(simp add: array_length_ahm_rehash_aux')
with inv have bucket: "bucket_ok (array_length a) h (array_get a h)"
and dist: "distinct (map fst (array_get a h))"
by(auto elim: ahm_invar_auxE)
let ?h = "bounded_hashcode_nat (array_length a) k"
from hlen bucket show "bucket_ok (array_length ?a) h (array_get ?a h)"
by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_length_ahm_rehash_aux' array_get_array_set_other dest: bucket_okD intro!: bucket_okI)
from dist hlen fresh
show "distinct (map fst (array_get ?a h))"
by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_get_array_set_other)
next
let ?f = "λn kvs. n + length kvs"
{ fix n :: nat and xs :: "('a × 'b) list list"
have "foldl ?f n xs = n + foldl ?f 0 xs"
by(induct xs arbitrary: rule: rev_induct) simp_all }
note fold = this
let ?h = "bounded_hashcode_nat (array_length a) k"
obtain xs where a [simp]: "a = Array xs" by(cases a)
from inv have [simp]: "bounded_hashcode_nat (length xs) k < length xs"
by(simp add: ahm_invar_aux_def bounded_hashcode_nat_bounds)
have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
by(auto elim: ahm_invar_auxE)
hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
thus "Suc n = array_foldl (λ_ n kvs. n + length kvs) 0 ?a"
by(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update)(subst (1 2 3 4) fold, simp)
next
from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
thus "1 < array_length ?a" by(simp add: array_length_ahm_rehash_aux')
qed
declare [[coercion_enabled = false]]
lemma ahm_rehash_aux_correct:
fixes a :: "(('key :: hashable) × 'val) list array"
assumes inv: "ahm_invar_aux n a"
and "sz > 1"
shows "ahm_invar_aux n (ahm_rehash_aux a sz)" (is "?thesis1")
and "ahm_α_aux (ahm_rehash_aux a sz) = ahm_α_aux a" (is "?thesis2")
proof -
let ?a = "ahm_rehash_aux a sz"
let ?I = "λit a'. ahm_invar_aux (n - card it) a' ∧ array_length a' = sz ∧ (∀k. if k ∈ it then ahm_α_aux a' k = None else ahm_α_aux a' k = ahm_α_aux a k)"
have "?I {} ?a ∨ (∃it⊆dom (ahm_α_aux a). it ≠ {} ∧ ¬ True ∧ ?I it ?a)"
unfolding ahm_rehash_aux_def
proof (rule map_iterator_rule_P[OF ahm_iteratei_aux_impl[OF inv], where
c = "λ_. True" and f="ahm_rehash_aux' sz" and ?σ0.0 = "new_array [] sz"
and I="?I"]
)
from inv have "card (dom (ahm_α_aux a)) = n" by(rule ahm_invar_aux_card_dom_ahm_α_auxD)
moreover from ‹1 < sz› have "ahm_invar_aux 0 (new_array ([] :: ('key × 'val) list) sz)"
by(rule ahm_invar_aux_new_array)
moreover {
fix k
assume "k ∉ dom (ahm_α_aux a)"
hence "ahm_α_aux a k = None" by auto
moreover have "bounded_hashcode_nat sz k < sz" using ‹1 < sz›
by(simp add: bounded_hashcode_nat_bounds)
ultimately have "ahm_α_aux (new_array [] sz) k = ahm_α_aux a k" by simp }
ultimately show "?I (dom (ahm_α_aux a)) (new_array [] sz)"
by(auto simp add: bounded_hashcode_nat_bounds[OF ‹1 < sz›])
next
fix k :: 'key
and v :: 'val
and it a'
assume "k ∈ it" "ahm_α_aux a k = Some v"
and it_sub: "it ⊆ dom (ahm_α_aux a)"
and I: "?I it a'"
from I have inv': "ahm_invar_aux (n - card it) a'"
and a'_eq_a: "⋀k. k ∉ it ⟹ ahm_α_aux a' k = ahm_α_aux a k"
and a'_None: "⋀k. k ∈ it ⟹ ahm_α_aux a' k = None"
and [simp]: "sz = array_length a'" by(auto split: if_split_asm)
from it_sub finite_dom_ahm_α_aux[OF inv] have "finite it" by(rule finite_subset)
moreover with ‹k ∈ it› have "card it > 0" by(auto simp add: card_gt_0_iff)
moreover from finite_dom_ahm_α_aux[OF inv] it_sub
have "card it ≤ card (dom (ahm_α_aux a))" by(rule card_mono)
moreover have "… = n" using inv
by(simp add: ahm_invar_aux_card_dom_ahm_α_auxD)
ultimately have "n - card (it - {k}) = (n - card it) + 1" using ‹k ∈ it› by auto
moreover from ‹k ∈ it› have "ahm_α_aux a' k = None" by(rule a'_None)
hence "k ∉ fst ` set (array_get a' (bounded_hashcode_nat (array_length a') k))"
by(simp add: map_of_eq_None_iff)
ultimately have "ahm_invar_aux (n - card (it - {k})) (ahm_rehash_aux' sz (k, v) a')"
using inv' by(auto intro: ahm_rehash_aux'_preserves_ahm_invar_aux)
moreover have "array_length (ahm_rehash_aux' sz (k, v) a') = sz"
by(simp add: array_length_ahm_rehash_aux')
moreover {
fix k'
assume "k' ∈ it - {k}"
with bounded_hashcode_nat_bounds[OF ‹1 < sz›, of k'] a'_None[of k']
have "ahm_α_aux (ahm_rehash_aux' sz (k, v) a') k' = None"
by(cases "bounded_hashcode_nat sz k = bounded_hashcode_nat sz k'")(auto simp add: array_get_array_set_other ahm_rehash_aux'_def Let_def)
} moreover {
fix k'
assume "k' ∉ it - {k}"
with bounded_hashcode_nat_bounds[OF ‹1 < sz›, of k'] bounded_hashcode_nat_bounds[OF ‹1 < sz›, of k] a'_eq_a[of k'] ‹k ∈ it›
have "ahm_α_aux (ahm_rehash_aux' sz (k, v) a') k' = ahm_α_aux a k'"
unfolding ahm_rehash_aux'_def Let_def using ‹ahm_α_aux a k = Some v›
by(cases "bounded_hashcode_nat sz k = bounded_hashcode_nat sz k'")(case_tac [!] "k' = k", simp_all add: array_get_array_set_other) }
ultimately show "?I (it - {k}) (ahm_rehash_aux' sz (k, v) a')" by simp
qed auto
thus ?thesis1 ?thesis2 unfolding ahm_rehash_aux_def
by(auto intro: ext)
qed
lemma ahm_rehash_correct:
fixes hm :: "('key :: hashable, 'val) hashmap"
assumes inv: "ahm_invar hm"
and "sz > 1"
shows "ahm_invar (ahm_rehash hm sz)" "ahm_α (ahm_rehash hm sz) = ahm_α hm"
using assms
by -(case_tac [!] hm, auto intro: ahm_rehash_aux_correct)
subsection ‹@{term ahm_update}›
lemma ahm_update_aux_correct:
assumes inv: "ahm_invar hm"
shows "ahm_invar (ahm_update_aux hm k v)" (is ?thesis1)
and "ahm_α (ahm_update_aux hm k v) = (ahm_α hm)(k ↦ v)" (is ?thesis2)
proof -
obtain a n where [simp]: "hm = HashMap a n" by(cases hm)
let ?h = "bounded_hashcode_nat (array_length a) k"
let ?a' = "array_set a ?h (AList.update k v (array_get a ?h))"
let ?n' = "if map_of (array_get a ?h) k = None then n + 1 else n"
have "ahm_invar (HashMap ?a' ?n')" unfolding ahm_invar.simps
proof(rule ahm_invar_auxI)
fix h
assume "h < array_length ?a'"
hence "h < array_length a" by simp
with inv have "bucket_ok (array_length a) h (array_get a h)"
by(auto elim: ahm_invar_auxE)
thus "bucket_ok (array_length ?a') h (array_get ?a' h)"
using ‹h < array_length a›
apply(cases "h = bounded_hashcode_nat (array_length a) k")
apply(fastforce intro!: bucket_okI simp add: dom_update array_get_array_set_other dest: bucket_okD del: imageE elim: imageE)+
done
from ‹h < array_length a› inv have "distinct (map fst (array_get a h))"
by(auto elim: ahm_invar_auxE)
with ‹h < array_length a›
show "distinct (map fst (array_get ?a' h))"
by(cases "h = bounded_hashcode_nat (array_length a) k")(auto simp add: array_get_array_set_other intro: distinct_update)
next
obtain xs where a [simp]: "a = Array xs" by(cases a)
let ?f = "λn kvs. n + length kvs"
{ fix n :: nat and xs :: "('a × 'b) list list"
have "foldl ?f n xs = n + foldl ?f 0 xs"
by(induct xs arbitrary: rule: rev_induct) simp_all }
note fold = this
from inv have [simp]: "bounded_hashcode_nat (length xs) k < length xs"
by(simp add: ahm_invar_aux_def bounded_hashcode_nat_bounds)
have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
by(auto elim: ahm_invar_auxE)
hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
thus "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
apply(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update map_of_eq_None_iff)
apply(subst (1 2 3 4 5 6 7 8) fold)
apply(simp add: length_update)
done
next
from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
thus "1 < array_length ?a'" by simp
qed
moreover have "ahm_α (ahm_update_aux hm k v) = ahm_α hm(k ↦ v)"
proof
fix k'
from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
with bounded_hashcode_nat_bounds[OF this, of k]
show "ahm_α (ahm_update_aux hm k v) k' = (ahm_α hm(k ↦ v)) k'"
by(cases "bounded_hashcode_nat (array_length a) k = bounded_hashcode_nat (array_length a) k'")(auto simp add: Let_def update_conv array_get_array_set_other)
qed
ultimately show ?thesis1 ?thesis2 by(simp_all add: Let_def)
qed
lemma ahm_update_correct:
assumes inv: "ahm_invar hm"
shows "ahm_invar (ahm_update k v hm)"
and "ahm_α (ahm_update k v hm) = (ahm_α hm)(k ↦ v)"
using assms
by(simp_all add: ahm_update_def Let_def ahm_rehash_correct ahm_update_aux_correct)
lemma ahm_update_impl:
"map_update ahm_α ahm_invar ahm_update"
by(unfold_locales)(simp_all add: ahm_update_correct)
subsection ‹@{term "ahm_delete"}›
lemma ahm_delete_correct:
assumes inv: "ahm_invar hm"
shows "ahm_invar (ahm_delete k hm)" (is "?thesis1")
and "ahm_α (ahm_delete k hm) = (ahm_α hm) |` (- {k})" (is "?thesis2")
proof -
obtain a n where hm [simp]: "hm = HashMap a n" by(cases hm)
let ?h = "bounded_hashcode_nat (array_length a) k"
let ?a' = "array_set a ?h (AList.delete k (array_get a ?h))"
let ?n' = "if map_of (array_get a (bounded_hashcode_nat (array_length a) k)) k = None then n else n - 1"
have "ahm_invar_aux ?n' ?a'"
proof(rule ahm_invar_auxI)
fix h
assume "h < array_length ?a'"
hence "h < array_length a" by simp
with inv have "bucket_ok (array_length a) h (array_get a h)"
and "1 < array_length a"
and "distinct (map fst (array_get a h))" by(auto elim: ahm_invar_auxE)
thus "bucket_ok (array_length ?a') h (array_get ?a' h)"
and "distinct (map fst (array_get ?a' h))"
using bounded_hashcode_nat_bounds[of "array_length a" k]
by-(case_tac [!] "h = bounded_hashcode_nat (array_length a) k", auto simp add: array_get_array_set_other set_delete_conv intro!: bucket_okI dest: bucket_okD intro: distinct_delete)
next
obtain xs where a [simp]: "a = Array xs" by(cases a)
let ?f = "λn kvs. n + length kvs"
{ fix n :: nat and xs :: "('a × 'b) list list"
have "foldl ?f n xs = n + foldl ?f 0 xs"
by(induct xs arbitrary: rule: rev_induct) simp_all }
note fold = this
from inv have [simp]: "bounded_hashcode_nat (length xs) k < length xs"
by(simp add: ahm_invar_aux_def bounded_hashcode_nat_bounds)
from inv have "distinct (map fst (array_get a ?h))" by(auto elim: ahm_invar_auxE)
moreover
have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
by(auto elim: ahm_invar_auxE)
hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
ultimately show "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
apply(simp add: array_foldl_foldl foldl_list_update map_of_eq_None_iff)
apply(subst (1 2 3 4 5 6 7 8) fold)
apply(auto simp add: length_distinct in_set_conv_nth)
done
next
from inv show "1 < array_length ?a'" by(auto elim: ahm_invar_auxE)
qed
thus "?thesis1" by(auto simp add: Let_def)
have "ahm_α_aux ?a' = ahm_α_aux a |` (- {k})"
proof
fix k' :: 'a
from inv have "bounded_hashcode_nat (array_length a) k < array_length a"
by(auto elim: ahm_invar_auxE simp add: bounded_hashcode_nat_bounds)
thus "ahm_α_aux ?a' k' = (ahm_α_aux a |` (- {k})) k'"
by(cases "?h = bounded_hashcode_nat (array_length a) k'")(auto simp add: restrict_map_def array_get_array_set_other delete_conv)
qed
thus ?thesis2 by(simp add: Let_def)
qed
lemma ahm_delete_impl:
"map_delete ahm_α ahm_invar ahm_delete"
by(unfold_locales)(blast intro: ahm_delete_correct)+
hide_const (open) HashMap ahm_empty bucket_ok ahm_invar ahm_α ahm_lookup
ahm_iteratei ahm_rehash hm_grow ahm_filled ahm_update ahm_delete
hide_type (open) hashmap
end
Theory ArrayHashMap
section ‹\isaheader{Array-based hash maps without explicit invariants}›
theory ArrayHashMap
imports ArrayHashMap_Impl
begin
subsection ‹Abstract type definition›
typedef (overloaded) ('key :: hashable, 'val) hashmap =
"{hm :: ('key, 'val) ArrayHashMap_Impl.hashmap. ArrayHashMap_Impl.ahm_invar hm}"
morphisms impl_of HashMap
proof
interpret map_empty ArrayHashMap_Impl.ahm_α ArrayHashMap_Impl.ahm_invar ArrayHashMap_Impl.ahm_empty
by(rule ahm_empty_impl)
show "ArrayHashMap_Impl.ahm_empty () ∈ ?hashmap"
by(simp add: empty_correct)
qed
type_synonym ('k,'v) ahm = "('k,'v) hashmap"
lemma ahm_invar_impl_of [simp, intro]: "ArrayHashMap_Impl.ahm_invar (impl_of hm)"
using impl_of[of hm] by simp
lemma HashMap_impl_of [code abstype]: "HashMap (impl_of t) = t"
by(rule impl_of_inverse)
subsection ‹Primitive operations›
definition ahm_empty_const :: "('key :: hashable, 'val) hashmap"
where "ahm_empty_const ≡ (HashMap (ArrayHashMap_Impl.ahm_empty ()))"
definition ahm_empty :: "unit ⇒ ('key :: hashable, 'val) hashmap"
where "ahm_empty ≡ λ_. ahm_empty_const"
definition ahm_α :: "('key :: hashable, 'val) hashmap ⇒ 'key ⇒ 'val option"
where "ahm_α hm = ArrayHashMap_Impl.ahm_α (impl_of hm)"
definition ahm_lookup :: "'key ⇒ ('key :: hashable, 'val) hashmap ⇒ 'val option"
where "ahm_lookup k hm = ArrayHashMap_Impl.ahm_lookup k (impl_of hm)"
definition ahm_iteratei :: "('key :: hashable, 'val) hashmap ⇒ ('key × 'val, 'σ) set_iterator"
where "ahm_iteratei hm = ArrayHashMap_Impl.ahm_iteratei (impl_of hm)"
definition ahm_update :: "'key ⇒ 'val ⇒ ('key :: hashable, 'val) hashmap ⇒ ('key, 'val) hashmap"
where
"ahm_update k v hm = HashMap (ArrayHashMap_Impl.ahm_update k v (impl_of hm))"
definition ahm_delete :: "'key ⇒ ('key :: hashable, 'val) hashmap ⇒ ('key, 'val) hashmap"
where
"ahm_delete k hm = HashMap (ArrayHashMap_Impl.ahm_delete k (impl_of hm))"
lemma impl_of_ahm_empty [code abstract]:
"impl_of ahm_empty_const = ArrayHashMap_Impl.ahm_empty ()"
by(simp add: ahm_empty_const_def HashMap_inverse)
lemma impl_of_ahm_update [code abstract]:
"impl_of (ahm_update k v hm) = ArrayHashMap_Impl.ahm_update k v (impl_of hm)"
by(simp add: ahm_update_def HashMap_inverse ahm_update_correct)
lemma impl_of_ahm_delete [code abstract]:
"impl_of (ahm_delete k hm) = ArrayHashMap_Impl.ahm_delete k (impl_of hm)"
by(simp add: ahm_delete_def HashMap_inverse ahm_delete_correct)
lemma finite_dom_ahm_α[simp]: "finite (dom (ahm_α hm))"
by (simp add: ahm_α_def finite_dom_ahm_α)
lemma ahm_empty_correct[simp]: "ahm_α (ahm_empty ()) = Map.empty"
by(simp add: ahm_α_def ahm_empty_def ahm_empty_const_def HashMap_inverse)
lemma ahm_lookup_correct[simp]: "ahm_lookup k m = ahm_α m k"
by (simp add: ahm_lookup_def ArrayHashMap_Impl.ahm_lookup_def ahm_α_def)
lemma ahm_update_correct[simp]: "ahm_α (ahm_update k v hm) = (ahm_α hm)(k ↦ v)"
by (simp add: ahm_α_def ahm_update_def ahm_update_correct HashMap_inverse)
lemma ahm_delete_correct[simp]:
"ahm_α (ahm_delete k hm) = (ahm_α hm) |` (- {k})"
by (simp add: ahm_α_def ahm_delete_def HashMap_inverse ahm_delete_correct)
lemma ahm_iteratei_impl[simp]: "map_iterator (ahm_iteratei m) (ahm_α m)"
unfolding ahm_iteratei_def ahm_α_def
apply (rule ahm_iteratei_correct)
by simp
subsection ‹ICF Integration›
definition [icf_rec_def]: "ahm_basic_ops ≡ ⦇
bmap_op_α = ahm_α,
bmap_op_invar = λ_. True,
bmap_op_empty = ahm_empty,
bmap_op_lookup = ahm_lookup,
bmap_op_update = ahm_update,
bmap_op_update_dj = ahm_update,
bmap_op_delete = ahm_delete,
bmap_op_list_it = ahm_iteratei
⦈"
setup Locale_Code.open_block
interpretation ahm_basic: StdBasicMap ahm_basic_ops
apply unfold_locales
apply (simp_all add: icf_rec_unf)
done
setup Locale_Code.close_block
definition [icf_rec_def]: "ahm_ops ≡ ahm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation ahm: StdMap ahm_ops
unfolding ahm_ops_def
by (rule ahm_basic.dflt_ops_impl)
interpretation ahm: StdMap_no_invar ahm_ops
apply unfold_locales
unfolding icf_rec_unf ..
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "ahm"›
lemma pi_ahm[proper_it]:
"proper_it' ahm_iteratei ahm_iteratei"
unfolding ahm_iteratei_def[abs_def]
ArrayHashMap_Impl.ahm_iteratei_def ArrayHashMap_Impl.ahm_iteratei_aux_def
apply (rule proper_it'I)
apply (case_tac "impl_of s")
apply simp
apply (rename_tac array nat)
apply (case_tac array)
apply simp
by (intro icf_proper_iteratorI)
interpretation pi_ahm: proper_it_loc ahm_iteratei ahm_iteratei
apply unfold_locales
apply (rule pi_ahm)
done
text ‹Code generator test›
definition test_codegen where "test_codegen ≡ (
ahm.add ,
ahm.add_dj ,
ahm.ball ,
ahm.bex ,
ahm.delete ,
ahm.empty ,
ahm.isEmpty ,
ahm.isSng ,
ahm.iterate ,
ahm.iteratei ,
ahm.list_it ,
ahm.lookup ,
ahm.restrict ,
ahm.sel ,
ahm.size ,
ahm.size_abort ,
ahm.sng ,
ahm.to_list ,
ahm.to_map ,
ahm.update ,
ahm.update_dj)"
export_code test_codegen checking SML
end
Theory ArrayMapImpl
section ‹\isaheader{Maps from Naturals by Arrays}›
theory ArrayMapImpl
imports
"../spec/MapSpec"
"../gen_algo/MapGA"
"../../Lib/Diff_Array"
begin
text_raw ‹\label{thy:ArrayMapImpl}›
type_synonym 'v iam = "'v option array"
subsection ‹Definitions›
definition iam_α :: "'v iam ⇒ nat ⇀ 'v" where
"iam_α a i ≡ if i < array_length a then array_get a i else None"
lemma [code]: "iam_α a i ≡ array_get_oo None a i"
unfolding iam_α_def array_get_oo_def .
abbreviation (input) iam_invar :: "'v iam ⇒ bool"
where "iam_invar ≡ λ_. True"
definition iam_empty :: "unit ⇒ 'v iam"
where "iam_empty ≡ λ_::unit. array_of_list []"
definition iam_lookup :: "nat ⇒ 'v iam ⇀ 'v"
where [code_unfold]: "iam_lookup k a ≡ iam_α a k"
definition "iam_increment (l::nat) idx ≡
max (idx + 1 - l) (2 * l + 3)"
lemma incr_correct: "¬ idx < l ⟹ idx < l + iam_increment l idx"
unfolding iam_increment_def by auto
definition iam_update :: "nat ⇒ 'v ⇒ 'v iam ⇒ 'v iam"
where "iam_update k v a ≡ let
l = array_length a;
a = if k < l then a else array_grow a (iam_increment l k) None
in
array_set a k (Some v)
"
lemma [code]: "iam_update k v a ≡ array_set_oo
(λ_. array_set
(array_grow a (iam_increment (array_length a) k) None) k (Some v))
a k (Some v)
"
unfolding iam_update_def array_set_oo_def
apply (rule eq_reflection)
apply (auto simp add: Let_def)
done
definition "iam_update_dj ≡ iam_update"
definition iam_delete :: "nat ⇒ 'v iam ⇒ 'v iam"
where "iam_delete k a ≡
if k<array_length a then array_set a k None else a"
lemma [code]: "iam_delete k a ≡ array_set_oo (λ_. a) a k None"
unfolding iam_delete_def array_set_oo_def by auto
fun iam_rev_iterateoi_aux
:: "nat ⇒ ('v iam) ⇒ ('σ⇒bool) ⇒ (nat × 'v⇒'σ⇒'σ) ⇒ 'σ ⇒ 'σ"
where
"iam_rev_iterateoi_aux 0 a c f σ = σ"
| "iam_rev_iterateoi_aux i a c f σ = (
if c σ then
iam_rev_iterateoi_aux (i - 1) a c f (
case array_get a (i - 1) of None ⇒ σ | Some x ⇒ f (i - 1, x) σ
)
else σ)"
definition iam_rev_iterateoi :: "'v iam ⇒ (nat × 'v,'σ) set_iterator" where
"iam_rev_iterateoi a ≡ iam_rev_iterateoi_aux (array_length a) a"
function iam_iterateoi_aux
:: "nat ⇒ nat ⇒ ('v iam) ⇒ ('σ⇒bool) ⇒ (nat × 'v⇒'σ⇒'σ) ⇒ 'σ ⇒ 'σ"
where
"iam_iterateoi_aux i len a c f σ =
(if i ≥ len ∨ ¬ c σ then σ else let
σ' = (case array_get a i of
None ⇒ σ
| Some x ⇒ f (i,x) σ)
in iam_iterateoi_aux (i + 1) len a c f σ')"
by pat_completeness auto
termination
by (relation "measure (λ(i,l,_). l - i)") auto
declare iam_iterateoi_aux.simps[simp del]
lemma iam_iterateoi_aux_csimps:
"i ≥ len ⟹ iam_iterateoi_aux i len a c f σ = σ"
"¬ c σ ⟹ iam_iterateoi_aux i len a c f σ = σ"
"⟦ i< len; c σ ⟧ ⟹ iam_iterateoi_aux i len a c f σ =
(case array_get a i of
None ⇒ iam_iterateoi_aux (i + 1) len a c f σ
| Some x ⇒ iam_iterateoi_aux (i + 1) len a c f (f (i,x) σ))"
apply (subst iam_iterateoi_aux.simps, simp)
apply (subst iam_iterateoi_aux.simps, simp)
apply (subst iam_iterateoi_aux.simps)
apply (auto split: option.split_asm option.split)
done
definition iam_iterateoi :: "'v iam ⇒ (nat × 'v,'σ) set_iterator" where
"iam_iterateoi a = iam_iterateoi_aux 0 (array_length a) a"
lemma iam_empty_impl: "map_empty iam_α iam_invar iam_empty"
apply unfold_locales
unfolding iam_α_def[abs_def] iam_empty_def
by auto
lemma iam_lookup_impl: "map_lookup iam_α iam_invar iam_lookup"
apply unfold_locales
unfolding iam_α_def[abs_def] iam_lookup_def
by auto
lemma array_get_set_iff: "i<array_length a ⟹
array_get (array_set a i x) j = (if i=j then x else array_get a j)"
by (auto simp: array_get_array_set_other)
lemma iam_update_impl: "map_update iam_α iam_invar iam_update"
apply unfold_locales
unfolding iam_α_def[abs_def] iam_update_def
apply (rule ext)
apply (auto simp: Let_def array_get_set_iff incr_correct)
done
lemma iam_update_dj_impl: "map_update_dj iam_α iam_invar iam_update_dj"
apply (unfold iam_update_dj_def)
apply (rule update_dj_by_update)
apply (rule iam_update_impl)
done
lemma iam_delete_impl: "map_delete iam_α iam_invar iam_delete"
apply unfold_locales
unfolding iam_α_def[abs_def] iam_delete_def
apply (rule ext)
apply (auto simp: Let_def array_get_set_iff)
done
lemma iam_rev_iterateoi_aux_foldli_conv :
"iam_rev_iterateoi_aux n a =
foldli (List.map_filter (λn. map_option (λv. (n, v)) (array_get a n)) (rev [0..<n]))"
by (induct n) (auto simp add: List.map_filter_def fun_eq_iff)
lemma iam_rev_iterateoi_foldli_conv :
"iam_rev_iterateoi a =
foldli (List.map_filter
(λn. map_option (λv. (n, v)) (array_get a n))
(rev [0..<(array_length a)]))"
unfolding iam_rev_iterateoi_def iam_rev_iterateoi_aux_foldli_conv by simp
lemma iam_rev_iterateoi_correct :
fixes m::"'a option array"
defines "kvs ≡ List.map_filter
(λn. map_option (λv. (n, v)) (array_get m n)) (rev [0..<(array_length m)])"
shows "map_iterator_rev_linord (iam_rev_iterateoi m) (iam_α m)"
proof (rule map_iterator_rev_linord_I [of kvs])
show "iam_rev_iterateoi m = foldli kvs"
unfolding iam_rev_iterateoi_foldli_conv kvs_def by simp
next
define al where "al = array_length m"
show dist_kvs: "distinct (map fst kvs)" and "sorted (rev (map fst kvs))"
unfolding kvs_def al_def[symmetric]
apply (induct al)
apply (simp_all
add: List.map_filter_simps set_map_filter image_iff sorted_append
split: option.split)
done
from dist_kvs
have "⋀i. map_of kvs i = iam_α m i"
unfolding kvs_def
apply (case_tac "array_get m i")
apply (simp_all
add: iam_α_def map_of_eq_None_iff set_map_filter image_iff)
done
thus "iam_α m = map_of kvs" by auto
qed
lemma iam_rev_iterateoi_impl:
"poly_map_rev_iterateoi iam_α iam_invar iam_rev_iterateoi"
apply unfold_locales
apply (simp add: iam_α_def[abs_def] dom_def)
apply (simp add: iam_rev_iterateoi_correct)
done
lemma iam_iteratei_impl:
"poly_map_iteratei iam_α iam_invar iam_rev_iterateoi"
proof -
interpret aux: poly_map_rev_iterateoi iam_α iam_invar iam_rev_iterateoi
by (rule iam_rev_iterateoi_impl)
show ?thesis
apply unfold_locales
apply (rule map_rev_iterator_linord_is_it)
by (rule aux.list_rev_it_correct)
qed
lemma iam_iterateoi_aux_foldli_conv :
"iam_iterateoi_aux n (array_length a) a c f σ =
foldli (List.map_filter (λn. map_option (λv. (n, v)) (array_get a n))
([n..<array_length a])) c f σ"
thm iam_iterateoi_aux.induct
apply (induct n "array_length a" a c f σ rule: iam_iterateoi_aux.induct)
apply (subst iam_iterateoi_aux.simps)
apply (auto split: option.split simp: map_filter_simps)
apply (subst (2) upt_conv_Cons)
apply simp
apply (simp add: map_filter_simps)
apply (subst (2) upt_conv_Cons)
apply simp
apply (simp add: map_filter_simps)
done
lemma iam_iterateoi_foldli_conv :
"iam_iterateoi a =
foldli (List.map_filter
(λn. map_option (λv. (n, v)) (array_get a n))
([0..<(array_length a)]))"
apply (intro ext)
unfolding iam_iterateoi_def iam_iterateoi_aux_foldli_conv
by simp
lemmas [simp] = map_filter_simps
lemma map_filter_append[simp]: "List.map_filter f (la@lb)
= List.map_filter f la @ List.map_filter f lb"
by (induct la) (auto split: option.split)
lemma iam_iterateoi_correct:
fixes m::"'a option array"
defines "kvs ≡ List.map_filter
(λn. map_option (λv. (n, v)) (array_get m n)) ([0..<(array_length m)])"
shows "map_iterator_linord (iam_iterateoi m) (iam_α m)"
proof (rule map_iterator_linord_I [of kvs])
show "iam_iterateoi m = foldli kvs"
unfolding iam_iterateoi_foldli_conv kvs_def by simp
next
define al where "al = array_length m"
show dist_kvs: "distinct (map fst kvs)" and "sorted (map fst kvs)"
unfolding kvs_def al_def[symmetric]
apply (induct al)
apply (simp_all
add: set_map_filter image_iff sorted_append
split: option.split)
done
from dist_kvs
have "⋀i. map_of kvs i = iam_α m i"
unfolding kvs_def
apply (case_tac "array_get m i")
apply (simp_all
add: iam_α_def map_of_eq_None_iff set_map_filter image_iff)
done
thus "iam_α m = map_of kvs" by auto
qed
lemma iam_iterateoi_impl:
"poly_map_iterateoi iam_α iam_invar iam_iterateoi"
apply unfold_locales
apply (simp add: iam_α_def[abs_def] dom_def)
apply (simp add: iam_iterateoi_correct)
done
definition iam_basic_ops :: "(nat,'a,'a iam) omap_basic_ops"
where [icf_rec_def]: "iam_basic_ops ≡ ⦇
bmap_op_α = iam_α,
bmap_op_invar = λ_. True,
bmap_op_empty = iam_empty,
bmap_op_lookup = iam_lookup,
bmap_op_update = iam_update,
bmap_op_update_dj = iam_update_dj,
bmap_op_delete = iam_delete,
bmap_op_list_it = iam_rev_iterateoi,
bmap_op_ordered_list_it = iam_iterateoi,
bmap_op_rev_list_it = iam_rev_iterateoi
⦈"
setup Locale_Code.open_block
interpretation iam_basic: StdBasicOMap iam_basic_ops
apply (rule StdBasicOMap.intro)
apply (rule StdBasicMap.intro)
apply (simp_all add: icf_rec_unf)
apply (rule iam_empty_impl iam_lookup_impl iam_update_impl
iam_update_dj_impl iam_delete_impl iam_iteratei_impl
iam_iterateoi_impl iam_rev_iterateoi_impl)+
done
setup Locale_Code.close_block
definition [icf_rec_def]: "iam_ops ≡ iam_basic.dflt_oops"
setup Locale_Code.open_block
interpretation iam: StdOMap iam_ops
unfolding iam_ops_def
by (rule iam_basic.dflt_oops_impl)
interpretation iam: StdMap_no_invar iam_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "iam"›
lemma pi_iam[proper_it]:
"proper_it' iam_iterateoi iam_iterateoi"
apply (rule proper_it'I)
unfolding iam_iterateoi_foldli_conv
by (rule icf_proper_iteratorI)
lemma pi_iam_rev[proper_it]:
"proper_it' iam_rev_iterateoi iam_rev_iterateoi"
apply (rule proper_it'I)
unfolding iam_rev_iterateoi_foldli_conv
by (rule icf_proper_iteratorI)
interpretation pi_iam: proper_it_loc iam_iterateoi iam_iterateoi
apply unfold_locales by (rule pi_iam)
interpretation pi_iam_rev: proper_it_loc iam_rev_iterateoi iam_rev_iterateoi
apply unfold_locales by (rule pi_iam_rev)
text ‹Code generator test›
definition "test_codegen ≡ (
iam.add ,
iam.add_dj ,
iam.ball ,
iam.bex ,
iam.delete ,
iam.empty ,
iam.isEmpty ,
iam.isSng ,
iam.iterate ,
iam.iteratei ,
iam.iterateo ,
iam.iterateoi ,
iam.list_it ,
iam.lookup ,
iam.max ,
iam.min ,
iam.restrict ,
iam.rev_iterateo ,
iam.rev_iterateoi ,
iam.rev_list_it ,
iam.reverse_iterateo ,
iam.reverse_iterateoi ,
iam.sel ,
iam.size ,
iam.size_abort ,
iam.sng ,
iam.to_list ,
iam.to_map ,
iam.to_rev_list ,
iam.to_sorted_list ,
iam.update ,
iam.update_dj)"
export_code test_codegen checking SML
end
Theory ListSetImpl
section ‹\isaheader{Set Implementation by List}›
theory ListSetImpl
imports "../spec/SetSpec" "../gen_algo/SetGA" "../../Lib/Dlist_add"
begin
text_raw ‹\label{thy:ListSetImpl}›
type_synonym
'a ls = "'a dlist"
subsection "Definitions"
definition ls_α :: "'a ls ⇒ 'a set" where "ls_α l == set (list_of_dlist l)"
definition ls_basic_ops :: "('a,'a ls) set_basic_ops" where
[icf_rec_def]: "ls_basic_ops ≡ ⦇
bset_op_α = ls_α,
bset_op_invar = λ_. True,
bset_op_empty = λ_. Dlist.empty,
bset_op_memb = (λx s. Dlist.member s x),
bset_op_ins = Dlist.insert,
bset_op_ins_dj = Dlist.insert,
bset_op_delete = dlist_remove',
bset_op_list_it = dlist_iteratei
⦈"
setup Locale_Code.open_block
interpretation ls_basic: StdBasicSet ls_basic_ops
apply unfold_locales
unfolding ls_basic_ops_def ls_α_def[abs_def]
apply (auto simp: dlist_member_empty Dlist.member_def List.member_def
dlist_iteratei_correct
dlist_remove'_correct set_dlist_remove1'
)
done
setup Locale_Code.close_block
definition [icf_rec_def]: "ls_ops ≡ ls_basic.dflt_ops⦇
set_op_to_list := list_of_dlist
⦈"
setup Locale_Code.open_block
interpretation ls: StdSetDefs ls_ops .
interpretation ls: StdSet ls_ops
proof -
interpret aux: StdSet ls_basic.dflt_ops
by (rule ls_basic.dflt_ops_impl)
show "StdSet ls_ops"
unfolding ls_ops_def
apply (rule StdSet_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (unfold_locales)
apply (simp_all add: ls_α_def)
done
qed
interpretation ls: StdSet_no_invar ls_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "ls"›
lemma pi_ls[proper_it]:
"proper_it' dlist_iteratei dlist_iteratei"
apply (rule proper_it'I)
unfolding dlist_iteratei_def
by (intro icf_proper_iteratorI)
lemma pi_ls'[proper_it]:
"proper_it' ls.iteratei ls.iteratei"
apply (rule proper_it'I)
unfolding ls.iteratei_def
by (intro icf_proper_iteratorI)
interpretation pi_ls: proper_it_loc dlist_iteratei dlist_iteratei
apply unfold_locales by (rule pi_ls)
interpretation pi_ls': proper_it_loc ls.iteratei ls.iteratei
apply unfold_locales by (rule pi_ls')
definition test_codegen where "test_codegen ≡ (
ls.empty,
ls.memb,
ls.ins,
ls.delete,
ls.list_it,
ls.sng,
ls.isEmpty,
ls.isSng,
ls.ball,
ls.bex,
ls.size,
ls.size_abort,
ls.union,
ls.union_dj,
ls.diff,
ls.filter,
ls.inter,
ls.subset,
ls.equal,
ls.disjoint,
ls.disjoint_witness,
ls.sel,
ls.to_list,
ls.from_list
)"
export_code test_codegen checking SML
end
Theory ListSetImpl_Invar
section ‹\isaheader{Set Implementation by List with explicit invariants}›
theory ListSetImpl_Invar
imports
"../spec/SetSpec"
"../gen_algo/SetGA"
"../../Lib/Dlist_add"
begin
text_raw ‹\label{thy:ListSetImpl_Invar}›
type_synonym
'a lsi = "'a list"
subsection "Definitions"
definition lsi_ins :: "'a ⇒ 'a lsi ⇒ 'a lsi" where "lsi_ins x l == if List.member l x then l else x#l"
definition lsi_basic_ops :: "('a,'a lsi) set_basic_ops" where
[icf_rec_def]: "lsi_basic_ops ≡ ⦇
bset_op_α = set,
bset_op_invar = distinct,
bset_op_empty = λ_. [],
bset_op_memb = (λx s. List.member s x),
bset_op_ins = lsi_ins,
bset_op_ins_dj = (#),
bset_op_delete = λx l. Dlist_add.dlist_remove1' x [] l,
bset_op_list_it = foldli
⦈"
setup Locale_Code.open_block
interpretation lsi_basic: StdBasicSet lsi_basic_ops
apply unfold_locales
unfolding lsi_basic_ops_def lsi_ins_def[abs_def]
apply (auto simp: List.member_def set_dlist_remove1'
distinct_remove1')
done
setup Locale_Code.close_block
definition [icf_rec_def]: "lsi_ops ≡ lsi_basic.dflt_ops ⦇
set_op_union_dj := (@),
set_op_to_list := id
⦈"
setup Locale_Code.open_block
interpretation lsi: StdSet lsi_ops
proof -
interpret aux: StdSet lsi_basic.dflt_ops by (rule lsi_basic.dflt_ops_impl)
show "StdSet lsi_ops"
unfolding lsi_ops_def
apply (rule StdSet_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf)
apply (unfold_locales, auto)
done
qed
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "lsi"›
lemma pi_lsi[proper_it]:
"proper_it' foldli foldli"
by (intro icf_proper_iteratorI proper_it'I)
interpretation pi_lsi: proper_it_loc foldli foldli
apply unfold_locales by (rule pi_lsi)
definition test_codegen where "test_codegen ≡ (
lsi.empty,
lsi.memb,
lsi.ins,
lsi.delete,
lsi.list_it,
lsi.sng,
lsi.isEmpty,
lsi.isSng,
lsi.ball,
lsi.bex,
lsi.size,
lsi.size_abort,
lsi.union,
lsi.union_dj,
lsi.diff,
lsi.filter,
lsi.inter,
lsi.subset,
lsi.equal,
lsi.disjoint,
lsi.disjoint_witness,
lsi.sel,
lsi.to_list,
lsi.from_list
)"
export_code test_codegen checking SML
end
Theory ListSetImpl_NotDist
section ‹\isaheader{Set Implementation by non-distinct Lists}›
theory ListSetImpl_NotDist
imports
"../spec/SetSpec"
"../gen_algo/SetGA"
begin
text_raw ‹\label{thy:ListSetImpl_NotDist}›
type_synonym
'a lsnd = "'a list"
subsection "Definitions"
definition lsnd_α :: "'a lsnd ⇒ 'a set" where "lsnd_α == set"
abbreviation (input) lsnd_invar
:: "'a lsnd ⇒ bool" where "lsnd_invar == (λ_. True)"
definition lsnd_empty :: "unit ⇒ 'a lsnd" where "lsnd_empty == (λ_::unit. [])"
definition lsnd_memb :: "'a ⇒ 'a lsnd ⇒ bool" where "lsnd_memb x l == List.member l x"
definition lsnd_ins :: "'a ⇒ 'a lsnd ⇒ 'a lsnd" where "lsnd_ins x l == x#l"
definition lsnd_ins_dj :: "'a ⇒ 'a lsnd ⇒ 'a lsnd" where "lsnd_ins_dj x l == x#l"
definition lsnd_delete :: "'a ⇒ 'a lsnd ⇒ 'a lsnd" where "lsnd_delete x l == remove_rev x l"
definition lsnd_iteratei :: "'a lsnd ⇒ ('a,'σ) set_iterator"
where "lsnd_iteratei l = foldli (remdups l)"
definition lsnd_isEmpty :: "'a lsnd ⇒ bool" where "lsnd_isEmpty s == s=[]"
definition lsnd_union :: "'a lsnd ⇒ 'a lsnd ⇒ 'a lsnd"
where "lsnd_union s1 s2 == revg s1 s2"
definition lsnd_union_dj :: "'a lsnd ⇒ 'a lsnd ⇒ 'a lsnd"
where "lsnd_union_dj s1 s2 == revg s1 s2"
definition lsnd_to_list :: "'a lsnd ⇒ 'a list" where "lsnd_to_list == remdups"
definition list_to_lsnd :: "'a list ⇒ 'a lsnd" where "list_to_lsnd == id"
subsection "Correctness"
lemmas lsnd_defs =
lsnd_α_def
lsnd_empty_def
lsnd_memb_def
lsnd_ins_def
lsnd_ins_dj_def
lsnd_delete_def
lsnd_iteratei_def
lsnd_isEmpty_def
lsnd_union_def
lsnd_union_dj_def
lsnd_to_list_def
list_to_lsnd_def
lemma lsnd_empty_impl: "set_empty lsnd_α lsnd_invar lsnd_empty"
by (unfold_locales) (auto simp add: lsnd_defs)
lemma lsnd_memb_impl: "set_memb lsnd_α lsnd_invar lsnd_memb"
by (unfold_locales)(auto simp add: lsnd_defs in_set_member)
lemma lsnd_ins_impl: "set_ins lsnd_α lsnd_invar lsnd_ins"
by (unfold_locales) (auto simp add: lsnd_defs in_set_member)
lemma lsnd_ins_dj_impl: "set_ins_dj lsnd_α lsnd_invar lsnd_ins_dj"
by (unfold_locales) (auto simp add: lsnd_defs)
lemma lsnd_delete_impl: "set_delete lsnd_α lsnd_invar lsnd_delete"
by (unfold_locales) (auto simp add: lsnd_delete_def lsnd_α_def remove_rev_alt_def)
lemma lsnd_α_finite[simp, intro!]: "finite (lsnd_α l)"
by (auto simp add: lsnd_defs)
lemma lsnd_is_finite_set: "finite_set lsnd_α lsnd_invar"
by (unfold_locales) (auto simp add: lsnd_defs)
lemma lsnd_iteratei_impl: "poly_set_iteratei lsnd_α lsnd_invar lsnd_iteratei"
proof
fix l :: "'a list"
show "finite (lsnd_α l)"
unfolding lsnd_α_def by simp
show "set_iterator (lsnd_iteratei l) (lsnd_α l)"
apply (rule set_iterator_I [of "remdups l"])
apply (simp_all add: lsnd_α_def lsnd_iteratei_def)
done
qed
lemma lsnd_isEmpty_impl: "set_isEmpty lsnd_α lsnd_invar lsnd_isEmpty"
by(unfold_locales)(auto simp add: lsnd_defs)
lemma lsnd_union_impl: "set_union lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_union"
by(unfold_locales)(auto simp add: lsnd_defs)
lemma lsnd_union_dj_impl: "set_union_dj lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_union_dj"
by(unfold_locales)(auto simp add: lsnd_defs)
lemma lsnd_to_list_impl: "set_to_list lsnd_α lsnd_invar lsnd_to_list"
by(unfold_locales)(auto simp add: lsnd_defs)
lemma list_to_lsnd_impl: "list_to_set lsnd_α lsnd_invar list_to_lsnd"
by(unfold_locales)(auto simp add: lsnd_defs)
definition lsnd_basic_ops :: "('x,'x lsnd) set_basic_ops"
where [icf_rec_def]: "lsnd_basic_ops ≡ ⦇
bset_op_α = lsnd_α,
bset_op_invar = lsnd_invar,
bset_op_empty = lsnd_empty,
bset_op_memb = lsnd_memb,
bset_op_ins = lsnd_ins,
bset_op_ins_dj = lsnd_ins_dj,
bset_op_delete = lsnd_delete,
bset_op_list_it = lsnd_iteratei
⦈"
setup Locale_Code.open_block
interpretation lsnd_basic: StdBasicSet lsnd_basic_ops
apply (rule StdBasicSet.intro)
apply (simp_all add: icf_rec_unf)
apply (rule lsnd_empty_impl lsnd_memb_impl lsnd_ins_impl lsnd_ins_dj_impl
lsnd_delete_impl lsnd_iteratei_impl)+
done
setup Locale_Code.close_block
definition [icf_rec_def]: "lsnd_ops ≡ lsnd_basic.dflt_ops ⦇
set_op_isEmpty := lsnd_isEmpty,
set_op_union := lsnd_union,
set_op_union_dj := lsnd_union_dj,
set_op_to_list := lsnd_to_list,
set_op_from_list := list_to_lsnd
⦈"
setup Locale_Code.open_block
interpretation lsnd: StdSetDefs lsnd_ops .
interpretation lsnd: StdSet lsnd_ops
proof -
interpret aux: StdSet lsnd_basic.dflt_ops
by (rule lsnd_basic.dflt_ops_impl)
show "StdSet lsnd_ops"
unfolding lsnd_ops_def
apply (rule StdSet_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf
lsnd_isEmpty_impl lsnd_union_impl lsnd_union_dj_impl lsnd_to_list_impl
list_to_lsnd_impl
)
done
qed
interpretation lsnd: StdSet_no_invar lsnd_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "lsnd"›
lemma pi_lsnd[proper_it]:
"proper_it' lsnd_iteratei lsnd_iteratei"
apply (rule proper_it'I)
unfolding lsnd_iteratei_def
by (intro icf_proper_iteratorI)
interpretation pi_lsnd: proper_it_loc lsnd_iteratei lsnd_iteratei
apply unfold_locales by (rule pi_lsnd)
definition test_codegen where "test_codegen ≡ (
lsnd.empty,
lsnd.memb,
lsnd.ins,
lsnd.delete,
lsnd.list_it,
lsnd.sng,
lsnd.isEmpty,
lsnd.isSng,
lsnd.ball,
lsnd.bex,
lsnd.size,
lsnd.size_abort,
lsnd.union,
lsnd.union_dj,
lsnd.diff,
lsnd.filter,
lsnd.inter,
lsnd.subset,
lsnd.equal,
lsnd.disjoint,
lsnd.disjoint_witness,
lsnd.sel,
lsnd.to_list,
lsnd.from_list
)"
export_code test_codegen checking SML
end
Theory ListSetImpl_Sorted
section ‹\isaheader{Set Implementation by sorted Lists}›
theory ListSetImpl_Sorted
imports
"../spec/SetSpec"
"../gen_algo/SetGA"
"../../Lib/Sorted_List_Operations"
begin
text_raw ‹\label{thy:ListSetImpl_Sorted}›
type_synonym
'a lss = "'a list"
subsection "Definitions"
definition lss_α :: "'a lss ⇒ 'a set" where "lss_α == set"
definition lss_invar :: "'a::{linorder} lss ⇒ bool" where "lss_invar l == distinct l ∧ sorted l"
definition lss_empty :: "unit ⇒ 'a lss" where "lss_empty == (λ_::unit. [])"
definition lss_memb :: "'a::{linorder} ⇒ 'a lss ⇒ bool" where "lss_memb x l == Sorted_List_Operations.memb_sorted l x"
definition lss_ins :: "'a::{linorder} ⇒ 'a lss ⇒ 'a lss" where "lss_ins x l == insertion_sort x l"
definition lss_ins_dj :: "'a::{linorder} ⇒ 'a lss ⇒ 'a lss" where "lss_ins_dj == lss_ins"
definition lss_delete :: "'a::{linorder} ⇒ 'a lss ⇒ 'a lss" where "lss_delete x l == delete_sorted x l"
definition lss_iterateoi :: "'a lss ⇒ ('a,'σ) set_iterator"
where "lss_iterateoi l = foldli l"
definition lss_reverse_iterateoi :: "'a lss ⇒ ('a,'σ) set_iterator"
where "lss_reverse_iterateoi l = foldli (rev l)"
definition lss_iteratei :: "'a lss ⇒ ('a,'σ) set_iterator"
where "lss_iteratei l = foldli l"
definition lss_isEmpty :: "'a lss ⇒ bool" where "lss_isEmpty s == s=[]"
definition lss_union :: "'a::{linorder} lss ⇒ 'a lss ⇒ 'a lss"
where "lss_union s1 s2 == Misc.merge s1 s2"
definition lss_union_list :: "'a::{linorder} lss list ⇒ 'a lss"
where "lss_union_list l == merge_list [] l"
definition lss_inter :: "'a::{linorder} lss ⇒ 'a lss ⇒ 'a lss"
where "lss_inter == inter_sorted"
definition lss_union_dj :: "'a::{linorder} lss ⇒ 'a lss ⇒ 'a lss"
where "lss_union_dj == lss_union"
definition lss_image_filter
where "lss_image_filter f l =
mergesort_remdups (List.map_filter f l)"
definition lss_filter where [code_unfold]: "lss_filter = List.filter"
definition lss_inj_image_filter
where "lss_inj_image_filter == lss_image_filter"
definition "lss_image == iflt_image lss_image_filter"
definition "lss_inj_image == iflt_inj_image lss_inj_image_filter"
definition lss_to_list :: "'a lss ⇒ 'a list" where "lss_to_list == id"
definition list_to_lss :: "'a::{linorder} list ⇒ 'a lss" where "list_to_lss == mergesort_remdups"
subsection "Correctness"
lemmas lss_defs =
lss_α_def
lss_invar_def
lss_empty_def
lss_memb_def
lss_ins_def
lss_ins_dj_def
lss_delete_def
lss_iteratei_def
lss_isEmpty_def
lss_union_def
lss_union_list_def
lss_inter_def
lss_union_dj_def
lss_image_filter_def
lss_inj_image_filter_def
lss_image_def
lss_inj_image_def
lss_to_list_def
list_to_lss_def
lemma lss_empty_impl: "set_empty lss_α lss_invar lss_empty"
by (unfold_locales) (auto simp add: lss_defs)
lemma lss_memb_impl: "set_memb lss_α lss_invar lss_memb"
by (unfold_locales) (auto simp add: lss_defs memb_sorted_correct)
lemma lss_ins_impl: "set_ins lss_α lss_invar lss_ins"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)
lemma lss_ins_dj_impl: "set_ins_dj lss_α lss_invar lss_ins_dj"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)
lemma lss_delete_impl: "set_delete lss_α lss_invar lss_delete"
by(unfold_locales)(auto simp add: lss_delete_def lss_α_def lss_invar_def delete_sorted_correct)
lemma lss_α_finite[simp, intro!]: "finite (lss_α l)"
by (auto simp add: lss_defs)
lemma lss_is_finite_set: "finite_set lss_α lss_invar"
by (unfold_locales) (auto simp add: lss_defs)
lemma lss_iterateoi_impl: "poly_set_iterateoi lss_α lss_invar lss_iterateoi"
proof
fix l :: "'a::{linorder} list"
assume invar_l: "lss_invar l"
show "finite (lss_α l)"
unfolding lss_α_def by simp
from invar_l
show "set_iterator_linord (lss_iterateoi l) (lss_α l)"
apply (rule_tac set_iterator_linord_I [of "l"])
apply (simp_all add: lss_α_def lss_invar_def lss_iterateoi_def)
done
qed
lemma lss_reverse_iterateoi_impl: "poly_set_rev_iterateoi lss_α lss_invar lss_reverse_iterateoi"
proof
fix l :: "'a list"
assume invar_l: "lss_invar l"
show "finite (lss_α l)"
unfolding lss_α_def by simp
from invar_l
show "set_iterator_rev_linord (lss_reverse_iterateoi l) (lss_α l)"
apply (rule_tac set_iterator_rev_linord_I [of "rev l"])
apply (simp_all add: lss_α_def lss_invar_def lss_reverse_iterateoi_def)
done
qed
lemma lss_iteratei_impl: "poly_set_iteratei lss_α lss_invar lss_iteratei"
proof
fix l :: "'a list"
assume invar_l: "lss_invar l"
show "finite (lss_α l)"
unfolding lss_α_def by simp
from invar_l
show "set_iterator (lss_iteratei l) (lss_α l)"
apply (rule_tac set_iterator_I [of "l"])
apply (simp_all add: lss_α_def lss_invar_def lss_iteratei_def)
done
qed
lemma lss_isEmpty_impl: "set_isEmpty lss_α lss_invar lss_isEmpty"
by(unfold_locales)(auto simp add: lss_defs)
lemma lss_inter_impl: "set_inter lss_α lss_invar lss_α lss_invar lss_α lss_invar lss_inter"
by (unfold_locales) (auto simp add: lss_defs inter_sorted_correct)
lemma lss_union_impl: "set_union lss_α lss_invar lss_α lss_invar lss_α lss_invar lss_union"
by (unfold_locales) (auto simp add: lss_defs merge_correct)
lemma lss_union_list_impl: "set_union_list lss_α lss_invar lss_α lss_invar lss_union_list"
proof
fix l :: "'a::{linorder} lss list"
assume "∀s1∈set l. lss_invar s1"
with merge_list_correct [of l "[]"]
show "lss_α (lss_union_list l) = ⋃{lss_α s1 |s1. s1 ∈ set l}"
"lss_invar (lss_union_list l)"
by (auto simp add: lss_defs)
qed
lemma lss_union_dj_impl: "set_union_dj lss_α lss_invar lss_α lss_invar lss_α lss_invar lss_union_dj"
by (unfold_locales) (auto simp add: lss_defs merge_correct)
lemma lss_image_filter_impl : "set_image_filter lss_α lss_invar lss_α lss_invar lss_image_filter"
apply (unfold_locales)
apply (simp_all add:
lss_invar_def lss_image_filter_def lss_α_def mergesort_remdups_correct
set_map_filter Bex_def)
done
lemma lss_inj_image_filter_impl : "set_inj_image_filter lss_α lss_invar lss_α lss_invar lss_inj_image_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_inj_image_filter_def lss_image_filter_def
mergesort_remdups_correct lss_α_def
set_map_filter Bex_def)
done
lemma lss_filter_impl : "set_filter lss_α lss_invar lss_α lss_invar lss_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_filter_def sorted_filter lss_α_def
set_map_filter Bex_def sorted_filter')
done
lemmas lss_image_impl = iflt_image_correct[OF lss_image_filter_impl, folded lss_image_def]
lemmas lss_inj_image_impl = iflt_inj_image_correct[OF lss_inj_image_filter_impl, folded lss_inj_image_def]
lemma lss_to_list_impl: "set_to_list lss_α lss_invar lss_to_list"
by(unfold_locales)(auto simp add: lss_defs)
lemma list_to_lss_impl: "list_to_set lss_α lss_invar list_to_lss"
by (unfold_locales) (auto simp add: lss_defs mergesort_remdups_correct)
definition lss_basic_ops :: "('x::linorder,'x lss) oset_basic_ops"
where [icf_rec_def]: "lss_basic_ops ≡ ⦇
bset_op_α = lss_α,
bset_op_invar = lss_invar,
bset_op_empty = lss_empty,
bset_op_memb = lss_memb,
bset_op_ins = lss_ins,
bset_op_ins_dj = lss_ins_dj,
bset_op_delete = lss_delete,
bset_op_list_it = lss_iteratei,
bset_op_ordered_list_it = lss_iterateoi,
bset_op_rev_list_it = lss_reverse_iterateoi
⦈"
setup Locale_Code.open_block
interpretation lss_basic: StdBasicOSet lss_basic_ops
apply (rule StdBasicOSet.intro)
apply (rule StdBasicSet.intro)
apply (simp_all add: icf_rec_unf)
apply (rule lss_empty_impl lss_memb_impl lss_ins_impl lss_ins_dj_impl
lss_delete_impl lss_iteratei_impl lss_iterateoi_impl
lss_reverse_iterateoi_impl)+
done
setup Locale_Code.close_block
definition [icf_rec_def]: "lss_ops ≡ lss_basic.dflt_oops ⦇
set_op_isEmpty := lss_isEmpty,
set_op_union := lss_union,
set_op_union_dj := lss_union_dj,
set_op_filter := lss_filter,
set_op_to_list := lss_to_list,
set_op_from_list := list_to_lss
⦈"
setup Locale_Code.open_block
interpretation lss: StdOSetDefs lss_ops .
interpretation lss: StdOSet lss_ops
proof -
interpret aux: StdOSet lss_basic.dflt_oops
by (rule lss_basic.dflt_oops_impl)
show "StdOSet lss_ops"
unfolding lss_ops_def
apply (rule StdOSet_intro)
apply icf_locales
apply (simp_all add: icf_rec_unf
lss_isEmpty_impl lss_union_impl lss_union_dj_impl lss_to_list_impl
lss_filter_impl
list_to_lss_impl
)
done
qed
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "lss"›
lemma pi_lss[proper_it]:
"proper_it' lss_iteratei lss_iteratei"
apply (rule proper_it'I)
unfolding lss_iteratei_def
by (intro icf_proper_iteratorI)
interpretation pi_lss: proper_it_loc lss_iteratei lss_iteratei
apply unfold_locales by (rule pi_lss)
definition test_codegen where "test_codegen ≡ (
lss.empty,
lss.memb,
lss.ins,
lss.delete,
lss.list_it,
lss.sng,
lss.isEmpty,
lss.isSng,
lss.ball,
lss.bex,
lss.size,
lss.size_abort,
lss.union,
lss.union_dj,
lss.diff,
lss.filter,
lss.inter,
lss.subset,
lss.equal,
lss.disjoint,
lss.disjoint_witness,
lss.sel,
lss.to_list,
lss.from_list
)"
export_code test_codegen checking SML
end
Theory RBTSetImpl
section ‹\isaheader{Set Implementation by Red-Black-Tree}›
theory RBTSetImpl
imports
"../spec/SetSpec"
RBTMapImpl
"../gen_algo/SetByMap"
"../gen_algo/SetGA"
begin
text_raw ‹\label{thy:RBTSetImpl}›
subsection "Definitions"
type_synonym
'a rs = "('a::linorder,unit) rm"
setup Locale_Code.open_block
interpretation rs_sbm: OSetByOMap rm_basic_ops by unfold_locales
setup Locale_Code.close_block
definition rs_ops :: "('x::linorder,'x rs) oset_ops"
where [icf_rec_def]: "rs_ops ≡ rs_sbm.obasic.dflt_oops"
setup Locale_Code.open_block
interpretation rs: StdOSetDefs rs_ops .
interpretation rs: StdOSet rs_ops
unfolding rs_ops_def
by (rule rs_sbm.obasic.dflt_oops_impl)
interpretation rs: StdSet_no_invar rs_ops
by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "rs"›
lemmas rbt_it_to_it_map_code_unfold[code_unfold] =
it_to_it_map_fold'[OF pi_rm]
it_to_it_map_fold'[OF pi_rm_rev]
lemma pi_rs[proper_it]:
"proper_it' rs.iteratei rs.iteratei"
"proper_it' rs.iterateoi rs.iterateoi"
"proper_it' rs.rev_iterateoi rs.rev_iterateoi"
unfolding rs.iteratei_def[abs_def] rs.iterateoi_def[abs_def]
rs.rev_iterateoi_def[abs_def]
by (rule proper_it'I icf_proper_iteratorI)+
interpretation
pi_rs: proper_it_loc rs.iteratei rs.iteratei +
pi_rs_o: proper_it_loc rs.iterateoi rs.iterateoi +
pi_rs_ro: proper_it_loc rs.rev_iterateoi rs.rev_iterateoi
by unfold_locales (rule pi_rs)+
definition test_codegen where "test_codegen ≡ (
rs.empty,
rs.memb,
rs.ins,
rs.delete,
rs.list_it,
rs.sng,
rs.isEmpty,
rs.isSng,
rs.ball,
rs.bex,
rs.size,
rs.size_abort,
rs.union,
rs.union_dj,
rs.diff,
rs.filter,
rs.inter,
rs.subset,
rs.equal,
rs.disjoint,
rs.disjoint_witness,
rs.sel,
rs.to_list,
rs.from_list,
rs.ordered_list_it,
rs.rev_list_it,
rs.min,
rs.max,
rs.to_sorted_list,
rs.to_rev_list
)"
export_code test_codegen checking SML
end
Theory HashSet
section ‹\isaheader{Hash Set}›
theory HashSet
imports
"../spec/SetSpec"
HashMap
"../gen_algo/SetByMap"
"../gen_algo/SetGA"
begin
text_raw ‹\label{thy:HashSet}›
subsection "Definitions"
type_synonym
'a hs = "('a::hashable,unit) hm"
setup Locale_Code.open_block
interpretation hs_sbm: SetByMap hm_basic_ops by unfold_locales
setup Locale_Code.close_block
definition hs_ops :: "('a::hashable,'a hs) set_ops"
where [icf_rec_def]:
"hs_ops ≡ hs_sbm.basic.dflt_ops"
setup Locale_Code.open_block
interpretation hs: StdSet hs_ops
unfolding hs_ops_def by (rule hs_sbm.basic.dflt_ops_impl)
interpretation hs: StdSet_no_invar hs_ops
by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "hs"›
lemmas hs_it_to_it_map_code_unfold[code_unfold] =
it_to_it_map_fold'[OF pi_hm]
lemma pi_hs[proper_it]: "proper_it' hs.iteratei hs.iteratei"
unfolding hs.iteratei_def[abs_def]
by (rule proper_it'I icf_proper_iteratorI)+
interpretation pi_hs: proper_it_loc hs.iteratei hs.iteratei
by unfold_locales (rule pi_hs)
definition test_codegen where "test_codegen ≡ (
hs.empty,
hs.memb,
hs.ins,
hs.delete,
hs.list_it,
hs.sng,
hs.isEmpty,
hs.isSng,
hs.ball,
hs.bex,
hs.size,
hs.size_abort,
hs.union,
hs.union_dj,
hs.diff,
hs.filter,
hs.inter,
hs.subset,
hs.equal,
hs.disjoint,
hs.disjoint_witness,
hs.sel,
hs.to_list,
hs.from_list
)"
export_code test_codegen checking SML
end
Theory TrieSetImpl
section ‹\isaheader{Set implementation via tries}›
theory TrieSetImpl imports
TrieMapImpl
"../gen_algo/SetByMap"
"../gen_algo/SetGA"
begin
subsection "Definitions"
type_synonym
'a ts = "('a, unit) trie"
setup Locale_Code.open_block
interpretation ts_sbm: SetByMap tm_basic_ops by unfold_locales
setup Locale_Code.close_block
definition ts_ops :: "('a list,'a ts) set_ops"
where [icf_rec_def]:
"ts_ops ≡ ts_sbm.basic.dflt_ops"
setup Locale_Code.open_block
interpretation ts: StdSet ts_ops
unfolding ts_ops_def by (rule ts_sbm.basic.dflt_ops_impl)
interpretation ts: StdSet_no_invar ts_ops
by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "ts"›
lemmas ts_it_to_it_map_code_unfold[code_unfold] =
it_to_it_map_fold'[OF pi_trie]
lemma pi_ts[proper_it]: "proper_it' ts.iteratei ts.iteratei"
unfolding ts.iteratei_def[abs_def]
by (rule proper_it'I icf_proper_iteratorI)+
interpretation pi_ts: proper_it_loc ts.iteratei ts.iteratei
by unfold_locales (rule pi_ts)
definition test_codegen where "test_codegen ≡ (
ts.empty,
ts.memb,
ts.ins,
ts.delete,
ts.list_it,
ts.sng,
ts.isEmpty,
ts.isSng,
ts.ball,
ts.bex,
ts.size,
ts.size_abort,
ts.union,
ts.union_dj,
ts.diff,
ts.filter,
ts.inter,
ts.subset,
ts.equal,
ts.disjoint,
ts.disjoint_witness,
ts.sel,
ts.to_list,
ts.from_list
)"
export_code test_codegen checking SML
end
Theory ArrayHashSet
theory ArrayHashSet
imports
ArrayHashMap
"../gen_algo/SetByMap"
"../gen_algo/SetGA"
begin
subsection "Definitions"
type_synonym
'a ahs = "('a::hashable,unit) ahm"
setup Locale_Code.open_block
interpretation ahs_sbm: SetByMap ahm_basic_ops by unfold_locales
setup Locale_Code.close_block
definition ahs_ops :: "('a::hashable,'a ahs) set_ops"
where [icf_rec_def]:
"ahs_ops ≡ ahs_sbm.basic.dflt_ops"
setup Locale_Code.open_block
interpretation ahs: StdSet ahs_ops
unfolding ahs_ops_def by (rule ahs_sbm.basic.dflt_ops_impl)
interpretation ahs: StdSet_no_invar ahs_ops
apply unfold_locales
by (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "ahs"›
lemmas ahs_it_to_it_map_code_unfold[code_unfold] =
it_to_it_map_fold'[OF pi_ahm]
lemma pi_ahs[proper_it]: "proper_it' ahs.iteratei ahs.iteratei"
unfolding ahs.iteratei_def[abs_def]
by (rule proper_it'I icf_proper_iteratorI)+
interpretation pi_ahs: proper_it_loc ahs.iteratei ahs.iteratei
by unfold_locales (rule pi_ahs)
definition test_codegen where "test_codegen ≡ (
ahs.empty,
ahs.memb,
ahs.ins,
ahs.delete,
ahs.list_it,
ahs.sng,
ahs.isEmpty,
ahs.isSng,
ahs.ball,
ahs.bex,
ahs.size,
ahs.size_abort,
ahs.union,
ahs.union_dj,
ahs.diff,
ahs.filter,
ahs.inter,
ahs.subset,
ahs.equal,
ahs.disjoint,
ahs.disjoint_witness,
ahs.sel,
ahs.to_list,
ahs.from_list
)"
export_code test_codegen checking SML
end
Theory ArraySetImpl
section ‹\isaheader{Set Implementation by Arrays}›
theory ArraySetImpl
imports
"../spec/SetSpec"
ArrayMapImpl
"../gen_algo/SetByMap"
"../gen_algo/SetGA"
begin
text_raw ‹\label{thy:ArraySetImpl}›
subsection "Definitions"
type_synonym ias = "(unit) iam"
setup Locale_Code.open_block
interpretation ias_sbm: OSetByOMap iam_basic_ops by unfold_locales
setup Locale_Code.close_block
definition ias_ops :: "(nat,ias) oset_ops"
where [icf_rec_def]:
"ias_ops ≡ ias_sbm.obasic.dflt_oops"
setup Locale_Code.open_block
interpretation ias: StdOSet ias_ops
unfolding ias_ops_def by (rule ias_sbm.obasic.dflt_oops_impl)
interpretation ias: StdSet_no_invar ias_ops
by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "ias"›
lemmas ias_it_to_it_map_code_unfold[code_unfold] =
it_to_it_map_fold'[OF pi_iam]
it_to_it_map_fold'[OF pi_iam_rev]
lemma pi_ias[proper_it]:
"proper_it' ias.iteratei ias.iteratei"
"proper_it' ias.iterateoi ias.iterateoi"
"proper_it' ias.rev_iterateoi ias.rev_iterateoi"
unfolding ias.iteratei_def[abs_def] ias.iterateoi_def[abs_def]
ias.rev_iterateoi_def[abs_def]
apply (rule proper_it'I icf_proper_iteratorI)+
done
interpretation
pi_ias: proper_it_loc ias.iteratei ias.iteratei +
pi_ias_o: proper_it_loc ias.iterateoi ias.iterateoi +
pi_ias_ro: proper_it_loc ias.rev_iterateoi ias.rev_iterateoi
apply unfold_locales by (rule pi_ias)+
definition test_codegen where "test_codegen ≡ (
ias.empty,
ias.memb,
ias.ins,
ias.delete,
ias.list_it,
ias.sng,
ias.isEmpty,
ias.isSng,
ias.ball,
ias.bex,
ias.size,
ias.size_abort,
ias.union,
ias.union_dj,
ias.diff,
ias.filter,
ias.inter,
ias.subset,
ias.equal,
ias.disjoint,
ias.disjoint_witness,
ias.sel,
ias.to_list,
ias.from_list,
ias.ordered_list_it,
ias.rev_list_it,
ias.min,
ias.max,
ias.to_sorted_list,
ias.to_rev_list
)"
export_code test_codegen checking SML
end
Theory Fifo
section ‹\isaheader{Fifo Queue by Pair of Lists}›
theory Fifo
imports
"../gen_algo/ListGA"
"../tools/Record_Intf"
"../tools/Locale_Code"
begin
text_raw ‹\label{thy:Fifo}›
lemma rev_tl_rev: "rev (tl (rev l)) = butlast l"
by (induct l) auto
text ‹
A fifo-queue is implemented by a pair of two lists (stacks).
New elements are pushed on the first stack, and elements are popped from
the second stack. If the second stack is empty, the first stack is reversed
and replaces the second stack.
If list reversal is implemented efficiently (what is the case in Isabelle/HOL,
cf @{thm [source] List.rev_conv_fold})
the amortized time per buffer operation is constant.
Moreover, this fifo implementation also supports efficient push and pop operations.
›
subsection ‹Definitions›
type_synonym 'a fifo = "'a list × 'a list"
text "Abstraction of the fifo to a list. The next element to be got is at
the head of the list, and new elements are appended at the end of the
list"
definition fifo_α :: "'a fifo ⇒ 'a list"
where "fifo_α F == snd F @ rev (fst F)"
text "This fifo implementation has no invariants, any pair of lists is a
valid fifo"
definition [simp, intro!]: "fifo_invar x = True"
definition fifo_empty :: "unit ⇒ 'a fifo"
where "fifo_empty == λ_::unit. ([],[])"
definition fifo_isEmpty :: "'a fifo ⇒ bool" where "fifo_isEmpty F == F=([],[])"
definition fifo_size :: "'a fifo ⇒ nat" where
"fifo_size F ≡ length (fst F) + length (snd F)"
definition fifo_appendr :: "'a ⇒ 'a fifo ⇒ 'a fifo"
where "fifo_appendr a F == (a#fst F, snd F)"
definition fifo_appendl :: "'a ⇒ 'a fifo ⇒ 'a fifo"
where "fifo_appendl x F == case F of (e,d) ⇒ (e,x#d)"
definition fifo_remover :: "'a fifo ⇒ ('a fifo × 'a)" where
"fifo_remover F ==
case fst F of
(a#l) ⇒ ((l,snd F),a) |
[] ⇒ let rp=rev (snd F) in
((tl rp,[]),hd rp)"
definition fifo_removel :: "'a fifo ⇒ ('a × 'a fifo)" where
"fifo_removel F ==
case snd F of
(a#l) ⇒ (a, (fst F, l)) |
[] ⇒ let rp=rev (fst F) in
(hd rp, ([], tl rp))
"
definition fifo_leftmost :: "'a fifo ⇒ 'a" where
"fifo_leftmost F ≡ case F of (_,x#_) ⇒ x | (l,[]) ⇒ last l"
definition fifo_rightmost :: "'a fifo ⇒ 'a" where
"fifo_rightmost F ≡ case F of (x#_,_) ⇒ x | ([],l) ⇒ last l"
definition "fifo_iteratei F ≡ foldli (fifo_α F)"
definition "fifo_rev_iteratei F ≡ foldri (fifo_α F)"
definition "fifo_get F i ≡
let
l2 = length (snd F)
in
if i < l2 then
snd F!i
else
(fst F)!(length (fst F) - Suc (i - l2))
"
definition "fifo_set F i a ≡ case F of (f1,f2) ⇒
let
l2 = length f2
in
if i < l2 then
(f1,f2[i:=a])
else
(f1[length (fst F) - Suc (i - l2) := a],f2)"
subsection "Correctness"
lemma fifo_empty_impl: "list_empty fifo_α fifo_invar fifo_empty"
apply (unfold_locales)
by (auto simp add: fifo_α_def fifo_empty_def)
lemma fifo_isEmpty_impl: "list_isEmpty fifo_α fifo_invar fifo_isEmpty"
apply (unfold_locales)
by (case_tac s) (auto simp add: fifo_isEmpty_def fifo_α_def)
lemma fifo_size_impl: "list_size fifo_α fifo_invar fifo_size"
apply unfold_locales
by (auto simp add: fifo_size_def fifo_α_def)
lemma fifo_appendr_impl: "list_appendr fifo_α fifo_invar fifo_appendr"
apply (unfold_locales)
by (auto simp add: fifo_appendr_def fifo_α_def)
lemma fifo_appendl_impl: "list_appendl fifo_α fifo_invar fifo_appendl"
apply (unfold_locales)
by (auto simp add: fifo_appendl_def fifo_α_def)
lemma fifo_removel_impl: "list_removel fifo_α fifo_invar fifo_removel"
apply (unfold_locales)
apply (case_tac s)
apply (case_tac b)
apply (auto simp add: fifo_removel_def fifo_α_def Let_def) [2]
apply (case_tac s)
apply (case_tac "b")
apply (auto simp add: fifo_removel_def fifo_α_def Let_def)
done
lemma fifo_remover_impl: "list_remover fifo_α fifo_invar fifo_remover"
apply (unfold_locales)
unfolding fifo_remover_def fifo_α_def Let_def
by (auto split: list.split simp: hd_rev rev_tl_rev butlast_append)
lemma fifo_leftmost_impl: "list_leftmost fifo_α fifo_invar fifo_leftmost"
apply unfold_locales
by (auto simp: fifo_leftmost_def fifo_α_def hd_rev split: list.split)
lemma fifo_rightmost_impl: "list_rightmost fifo_α fifo_invar fifo_rightmost"
apply unfold_locales
by (auto simp: fifo_rightmost_def fifo_α_def hd_rev split: list.split)
lemma fifo_get_impl: "list_get fifo_α fifo_invar fifo_get"
apply unfold_locales
apply (auto simp: fifo_α_def fifo_get_def Let_def nth_append rev_nth)
done
lemma fifo_set_impl: "list_set fifo_α fifo_invar fifo_set"
apply unfold_locales
apply (auto simp: fifo_α_def fifo_set_def Let_def list_update_append
rev_update)
done
definition [icf_rec_def]: "fifo_ops ≡ ⦇
list_op_α = fifo_α,
list_op_invar = fifo_invar,
list_op_empty = fifo_empty,
list_op_isEmpty = fifo_isEmpty,
list_op_size = fifo_size,
list_op_appendl = fifo_appendl,
list_op_removel = fifo_removel,
list_op_leftmost = fifo_leftmost,
list_op_appendr = fifo_appendr,
list_op_remover = fifo_remover,
list_op_rightmost = fifo_rightmost,
list_op_get = fifo_get,
list_op_set = fifo_set
⦈"
setup Locale_Code.open_block
interpretation fifo: StdList fifo_ops
apply (rule StdList.intro)
apply (simp_all add: icf_rec_unf)
apply (rule
fifo_empty_impl
fifo_isEmpty_impl
fifo_size_impl
fifo_appendl_impl
fifo_removel_impl
fifo_leftmost_impl
fifo_appendr_impl
fifo_remover_impl
fifo_rightmost_impl
fifo_get_impl
fifo_set_impl)+
done
interpretation fifo: StdList_no_invar fifo_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "fifo"›
definition test_codegen where "test_codegen ≡
(
fifo.empty,
fifo.isEmpty,
fifo.size,
fifo.appendl,
fifo.removel,
fifo.leftmost,
fifo.appendr,
fifo.remover,
fifo.rightmost,
fifo.get,
fifo.set,
fifo.iteratei,
fifo.rev_iteratei
)"
export_code test_codegen checking SML
end
Theory BinoPrioImpl
section ‹\isaheader{Implementation of Priority Queues by Binomial Heap}›
theory BinoPrioImpl
imports
"Binomial-Heaps.BinomialHeap"
"../spec/PrioSpec"
"../tools/Record_Intf"
"../tools/Locale_Code"
begin
type_synonym ('a,'b) bino = "('a,'b) BinomialHeap"
subsection "Definitions"
definition bino_α where "bino_α q ≡ BinomialHeap.to_mset q"
definition bino_insert where "bino_insert ≡ BinomialHeap.insert"
abbreviation (input) bino_invar :: "('a,'b) BinomialHeap ⇒ bool"
where "bino_invar ≡ λ_. True"
definition bino_find where "bino_find ≡ BinomialHeap.findMin"
definition bino_delete where "bino_delete ≡ BinomialHeap.deleteMin"
definition bino_meld where "bino_meld ≡ BinomialHeap.meld"
definition bino_empty where "bino_empty ≡ λ_::unit. BinomialHeap.empty"
definition bino_isEmpty where "bino_isEmpty = BinomialHeap.isEmpty"
definition [icf_rec_def]: "bino_ops == ⦇
prio_op_α = bino_α,
prio_op_invar = bino_invar,
prio_op_empty = bino_empty,
prio_op_isEmpty = bino_isEmpty,
prio_op_insert = bino_insert,
prio_op_find = bino_find,
prio_op_delete = bino_delete,
prio_op_meld = bino_meld
⦈"
lemmas bino_defs =
bino_α_def
bino_insert_def
bino_find_def
bino_delete_def
bino_meld_def
bino_empty_def
bino_isEmpty_def
subsection "Correctness"
theorem bino_empty_impl: "prio_empty bino_α bino_invar bino_empty"
by (unfold_locales, auto simp add: bino_defs)
theorem bino_isEmpty_impl: "prio_isEmpty bino_α bino_invar bino_isEmpty"
by unfold_locales
(simp add: bino_defs BinomialHeap.isEmpty_correct BinomialHeap.empty_correct)
theorem bino_find_impl: "prio_find bino_α bino_invar bino_find"
apply unfold_locales
apply (simp add: bino_defs BinomialHeap.empty_correct BinomialHeap.findMin_correct)
done
lemma bino_insert_impl: "prio_insert bino_α bino_invar bino_insert"
apply(unfold_locales)
apply(unfold bino_defs)
apply (simp_all add: BinomialHeap.insert_correct)
done
lemma bino_meld_impl: "prio_meld bino_α bino_invar bino_meld"
apply(unfold_locales)
apply(unfold bino_defs)
apply(simp_all add: BinomialHeap.meld_correct)
done
lemma bino_delete_impl:
"prio_delete bino_α bino_invar bino_find bino_delete"
apply intro_locales
apply (rule bino_find_impl)
apply(unfold_locales)
apply(simp_all add: bino_defs BinomialHeap.empty_correct BinomialHeap.deleteMin_correct)
done
setup Locale_Code.open_block
interpretation bino: StdPrio bino_ops
apply (rule StdPrio.intro)
apply (simp_all add: icf_rec_unf)
apply (rule
bino_empty_impl
bino_isEmpty_impl
bino_find_impl
bino_insert_impl
bino_meld_impl
bino_delete_impl
)+
done
interpretation bino: StdPrio_no_invar bino_ops
apply unfold_locales
apply (simp add: icf_rec_unf)
done
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "bino"›
definition test_codegen where "test_codegen = (
bino.empty,
bino.isEmpty,
bino.find,
bino.insert,
bino.meld,
bino.delete
)"
export_code test_codegen checking SML
end
Theory SkewPrioImpl
section ‹\isaheader{Implementation of Priority Queues by Skew Binomial Heaps}›
theory SkewPrioImpl
imports
"Binomial-Heaps.SkewBinomialHeap"
"../spec/PrioSpec"
"../tools/Record_Intf"
"../tools/Locale_Code"
begin
subsection "Definitions"
type_synonym ('a,'b) skew = "('a, 'b) SkewBinomialHeap"
definition skew_α where "skew_α q ≡ SkewBinomialHeap.to_mset q"
definition skew_insert where "skew_insert ≡ SkewBinomialHeap.insert"
abbreviation (input) skew_invar :: "('a, 'b) SkewBinomialHeap ⇒ bool"
where "skew_invar ≡ λ_. True"
definition skew_find where "skew_find ≡ SkewBinomialHeap.findMin"
definition skew_delete where "skew_delete ≡ SkewBinomialHeap.deleteMin"
definition skew_meld where "skew_meld ≡ SkewBinomialHeap.meld"
definition skew_empty where "skew_empty ≡ λ_::unit. SkewBinomialHeap.empty"
definition skew_isEmpty where "skew_isEmpty = SkewBinomialHeap.isEmpty"
definition [icf_rec_def]: "skew_ops == ⦇
prio_op_α = skew_α,
prio_op_invar = skew_invar,
prio_op_empty = skew_empty,
prio_op_isEmpty = skew_isEmpty,
prio_op_insert = skew_insert,
prio_op_find = skew_find,
prio_op_delete = skew_delete,
prio_op_meld = skew_meld
⦈"
lemmas skew_defs =
skew_α_def
skew_insert_def
skew_find_def
skew_delete_def
skew_meld_def
skew_empty_def
skew_isEmpty_def
subsection "Correctness"
theorem skew_empty_impl: "prio_empty skew_α skew_invar skew_empty"
by (unfold_locales, auto simp add: skew_defs)
theorem skew_isEmpty_impl: "prio_isEmpty skew_α skew_invar skew_isEmpty"
by unfold_locales
(simp add: skew_defs SkewBinomialHeap.isEmpty_correct SkewBinomialHeap.empty_correct)
theorem skew_find_impl: "prio_find skew_α skew_invar skew_find"
apply unfold_locales
apply (simp add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.findMin_correct)
done
lemma skew_insert_impl: "prio_insert skew_α skew_invar skew_insert"
apply(unfold_locales)
apply(unfold skew_defs)
apply (simp_all add: SkewBinomialHeap.insert_correct)
done
lemma skew_meld_impl: "prio_meld skew_α skew_invar skew_meld"
apply(unfold_locales)
apply(unfold skew_defs)
apply(simp_all add: SkewBinomialHeap.meld_correct)
done
lemma skew_delete_impl:
"prio_delete skew_α skew_invar skew_find skew_delete"
apply intro_locales
apply (rule skew_find_impl)
apply(unfold_locales)
apply(simp_all add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.deleteMin_correct)
done
setup Locale_Code.open_block
interpretation skew: StdPrio skew_ops
apply (rule StdPrio.intro)
apply (simp_all add: icf_rec_unf)
apply (rule
skew_empty_impl
skew_isEmpty_impl
skew_find_impl
skew_insert_impl
skew_meld_impl
skew_delete_impl
)+
done
interpretation skew: StdPrio_no_invar skew_ops
by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
definition test_codegen where "test_codegen ≡ (
skew.empty,
skew.isEmpty,
skew.find,
skew.insert,
skew.meld,
skew.delete
)"
export_code test_codegen checking SML
end
Theory FTAnnotatedListImpl
section ‹\isaheader{Implementation of Annotated Lists by 2-3 Finger Trees}›
theory FTAnnotatedListImpl
imports
"Finger-Trees.FingerTree"
"../tools/Locale_Code"
"../tools/Record_Intf"
"../spec/AnnotatedListSpec"
begin
type_synonym ('a,'b) ft = "('a,'b) FingerTree"
subsection "Definitions"
definition ft_α where
"ft_α ≡ FingerTree.toList"
abbreviation (input) ft_invar :: "('a,'b) FingerTree ⇒ bool" where
"ft_invar ≡ λ_. True"
definition ft_empty where
"ft_empty ≡ λ_::unit. FingerTree.empty"
definition ft_isEmpty where
"ft_isEmpty ≡ FingerTree.isEmpty"
definition ft_count where
"ft_count ≡ FingerTree.count"
definition ft_consl where
"ft_consl e a s = FingerTree.lcons (e,a) s"
definition ft_consr where
"ft_consr s e a = FingerTree.rcons s (e,a)"
definition ft_head where
"ft_head ≡ FingerTree.head"
definition ft_tail where
"ft_tail ≡ FingerTree.tail"
definition ft_headR where
"ft_headR ≡ FingerTree.headR"
definition ft_tailR where
"ft_tailR ≡ FingerTree.tailR"
definition ft_foldl where
"ft_foldl ≡ FingerTree.foldl"
definition ft_foldr where
"ft_foldr ≡ FingerTree.foldr"
definition ft_app where
"ft_app ≡ FingerTree.app"
definition ft_annot where
"ft_annot ≡ FingerTree.annot"
definition ft_splits where
"ft_splits ≡ FingerTree.splitTree"
lemmas ft_defs =
ft_α_def
ft_empty_def
ft_isEmpty_def
ft_count_def
ft_consl_def
ft_consr_def
ft_head_def
ft_tail_def
ft_headR_def
ft_tailR_def
ft_foldl_def
ft_foldr_def
ft_app_def
ft_annot_def
ft_splits_def
lemma ft_empty_impl: "al_empty ft_α ft_invar ft_empty"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.empty_correct)
done
lemma ft_consl_impl: "al_consl ft_α ft_invar ft_consl"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.lcons_correct)
done
lemma ft_consr_impl: "al_consr ft_α ft_invar ft_consr"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.rcons_correct)
done
lemma ft_isEmpty_impl: "al_isEmpty ft_α ft_invar ft_isEmpty"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.isEmpty_correct FingerTree.empty_correct)
done
lemma ft_count_impl: "al_count ft_α ft_invar ft_count"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.count_correct)
done
lemma ft_head_impl: "al_head ft_α ft_invar ft_head"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.head_correct FingerTree.empty_correct)
done
lemma ft_tail_impl: "al_tail ft_α ft_invar ft_tail"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.tail_correct FingerTree.empty_correct)
done
lemma ft_headR_impl: "al_headR ft_α ft_invar ft_headR"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.headR_correct FingerTree.empty_correct)
done
lemma ft_tailR_impl: "al_tailR ft_α ft_invar ft_tailR"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.tailR_correct FingerTree.empty_correct)
done
lemma ft_foldl_impl: "al_foldl ft_α ft_invar ft_foldl"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.foldl_correct)
done
lemma ft_foldr_impl: "al_foldr ft_α ft_invar ft_foldr"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.foldr_correct)
done
lemma ft_foldl_cunfold[code_unfold]:
"List.foldl f σ (ft_α t) = ft_foldl f σ t"
apply (auto simp add: ft_defs FingerTree.foldl_correct)
done
lemma ft_foldr_cunfold[code_unfold]:
"List.foldr f (ft_α t) σ = ft_foldr f t σ"
apply (auto simp add: ft_defs FingerTree.foldr_correct)
done
lemma ft_app_impl: "al_app ft_α ft_invar ft_app"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.app_correct)
done
lemma ft_annot_impl: "al_annot ft_α ft_invar ft_annot"
apply unfold_locales
apply (auto simp add: ft_defs FingerTree.annot_correct)
done
lemma ft_splits_impl: "al_splits ft_α ft_invar ft_splits"
apply unfold_locales
apply (unfold ft_defs)
apply (simp only: FingerTree.annot_correct[symmetric])
apply (frule (3) FingerTree.splitTree_correct(1))
apply (frule (3) FingerTree.splitTree_correct(2))
apply (frule (3) FingerTree.splitTree_correct(3))
apply (simp only: FingerTree.annot_correct[symmetric])
apply simp
done
subsubsection "Record Based Implementation"
definition [icf_rec_def]: "ft_ops = ⦇
alist_op_α = ft_α,
alist_op_invar = ft_invar,
alist_op_empty = ft_empty,
alist_op_isEmpty = ft_isEmpty,
alist_op_count = ft_count,
alist_op_consl = ft_consl,
alist_op_consr = ft_consr,
alist_op_head = ft_head,
alist_op_tail = ft_tail,
alist_op_headR = ft_headR,
alist_op_tailR = ft_tailR,
alist_op_app = ft_app,
alist_op_annot = ft_annot,
alist_op_splits = ft_splits
⦈"
setup Locale_Code.open_block
interpretation ft: StdAL ft_ops
apply (rule StdAL.intro)
apply (simp_all add: icf_rec_unf)
apply (rule
ft_empty_impl
ft_consl_impl
ft_consr_impl
ft_isEmpty_impl
ft_count_impl
ft_head_impl
ft_tail_impl
ft_headR_impl
ft_tailR_impl
ft_foldl_impl
ft_foldr_impl
ft_app_impl
ft_annot_impl
ft_splits_impl
)+
done
interpretation ft: StdAL_no_invar ft_ops
by (unfold_locales) (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "ft"›
definition "test_codegen ≡ (
ft.empty,
ft.isEmpty,
ft.count,
ft.consl,
ft.consr,
ft.head,
ft.tail,
ft.headR,
ft.tailR,
ft.app,
ft.annot,
ft.splits,
ft.foldl,
ft.foldr
)"
export_code test_codegen checking SML
end
Theory FTPrioImpl
section ‹\isaheader{Implementation of Priority Queues by Finger Trees}›
theory FTPrioImpl
imports FTAnnotatedListImpl
"../gen_algo/PrioByAnnotatedList"
begin
type_synonym ('a,'p) alprioi = "(unit, ('a, 'p) Prio) FingerTree"
setup Locale_Code.open_block
interpretation alprio_ga: alprio ft_ops by unfold_locales
setup Locale_Code.close_block
definition [icf_rec_def]: "alprioi_ops ≡ alprio_ga.alprio_ops"
setup Locale_Code.open_block
interpretation alprioi: StdPrio alprioi_ops
unfolding alprioi_ops_def
by (rule alprio_ga.alprio_ops_impl)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "alprioi"›
definition test_codegen where "test_codegen ≡ (
alprioi.empty,
alprioi.isEmpty,
alprioi.insert,
alprioi.find,
alprioi.delete,
alprioi.meld
)"
export_code test_codegen checking SML
end
Theory FTPrioUniqueImpl
section ‹\isaheader{Implementation of Unique Priority Queues by Finger Trees}›
theory FTPrioUniqueImpl
imports
FTAnnotatedListImpl
"../gen_algo/PrioUniqueByAnnotatedList"
begin
subsection "Definitions"
type_synonym ('a,'b) aluprioi = "(unit, ('a, 'b) LP) FingerTree"
setup Locale_Code.open_block
interpretation aluprio_ga: aluprio ft_ops by unfold_locales
setup Locale_Code.close_block
definition [icf_rec_def]: "aluprioi_ops ≡ aluprio_ga.aluprio_ops"
setup Locale_Code.open_block
interpretation aluprioi: StdUprio aluprioi_ops
unfolding aluprioi_ops_def
by (rule aluprio_ga.aluprio_ops_impl)
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "aluprioi"›
definition test_codegen where "test_codegen ≡ (
aluprioi.empty,
aluprioi.isEmpty,
aluprioi.insert,
aluprioi.pop,
aluprioi.prio
)"
export_code test_codegen checking SML
end
Theory ICF_Refine_Monadic
section ‹\isaheader{Refine-Monadci setup for ICF}›
theory ICF_Refine_Monadic
imports ICF_Impl
begin
text ‹
This theory sets up some lemmas that automate refinement proofs using
the Isabelle Collection Framework (ICF).
›
subsection ‹General Setup›
lemma (in set) drh[refine_dref_RELATES]:
"RELATES (build_rel α invar)" by (simp add: RELATES_def)
lemma (in map) drh[refine_dref_RELATES]:
"RELATES (build_rel α invar)" by (simp add: RELATES_def)
lemma (in uprio) drh[refine_dref_RELATES]: "RELATES (build_rel α invar)"
by (simp add: RELATES_def)
lemma (in prio) drh[refine_dref_RELATES]: "RELATES (build_rel α invar)"
by (simp add: RELATES_def)
lemmas (in StdSet) [refine_hsimp] = correct
lemmas (in StdMap) [refine_hsimp] = correct
lemma (in set_sel') pick_ref[refine_hsimp]:
"⟦ invar s; α s ≠ {}⟧ ⟹ the (sel' s (λ_. True)) ∈ α s"
by (auto elim!: sel'E)
text ‹
This definition is handy to be used on the abstract level.
›
definition "prio_pop_min q ≡ do {
ASSERT (dom q ≠ {});
SPEC (λ(e,w,q').
q'=q(e:=None) ∧
q e = Some w ∧
(∀ e' w'. q e' = Some w' ⟶ w≤w')
)
}"
lemma (in uprio_pop) prio_pop_min_refine[refine]:
"(q,q')∈build_rel α invar ⟹ RETURN (pop q)
≤ ⇓ (⟨Id,⟨Id,br α invar⟩prod_rel⟩prod_rel) (prio_pop_min q')"
unfolding prio_pop_min_def
apply refine_rcg
apply (clarsimp simp: prod_rel_def br_def)
apply (erule (1) popE)
apply (rule pw_leI)
apply (auto simp: refine_pw_simps intro: ranI)
done
subsection "Iterators"
lemmas (in poly_map_iteratei) [refine_transfer] = iteratei_correct
lemmas (in poly_map_iterateoi) [refine_transfer] = iterateoi_correct
lemmas (in map_no_invar) [refine_transfer] = invar
lemmas (in poly_set_iteratei) [refine_transfer] = iteratei_correct
lemmas (in poly_set_iterateoi) [refine_transfer] = iterateoi_correct
lemmas (in set_no_invar) [refine_transfer] = invar
lemma (in poly_set_iteratei) dres_ne_bot_iterate[refine_transfer]:
assumes A: "⋀x s. f x s ≠ dSUCCEED"
shows "iteratei r c (λx s. dbind s (f x)) (dRETURN s) ≠ dSUCCEED"
unfolding iteratei_def it_to_list_def it_to_it_def
apply (rule dres_foldli_ne_bot)
by (simp_all add: A)
lemma (in poly_set_iterateoi) dres_ne_bot_iterateo[refine_transfer]:
assumes A: "⋀x s. f x s ≠ dSUCCEED"
shows "iterateoi r c (λx s. dbind s (f x)) (dRETURN s) ≠ dSUCCEED"
unfolding iterateoi_def it_to_list_def it_to_it_def
apply (rule dres_foldli_ne_bot)
by (simp_all add: A)
lemma (in poly_map_iteratei) dres_ne_bot_map_iterate[refine_transfer]:
assumes A: "⋀x s. f x s ≠ dSUCCEED"
shows "iteratei r c (λx s. dbind s (f x)) (dRETURN s) ≠ dSUCCEED"
unfolding iteratei_def it_to_list_def it_to_it_def
apply (rule dres_foldli_ne_bot)
by (simp_all add: A)
lemma (in poly_set_iterateoi) dres_ne_bot_map_iterateo[refine_transfer]:
assumes A: "⋀x s. f x s ≠ dSUCCEED"
shows "iterateoi r c (λx s. dbind s (f x)) (dRETURN s) ≠ dSUCCEED"
unfolding iterateoi_def it_to_list_def it_to_it_def
apply (rule dres_foldli_ne_bot)
by (simp_all add: A)
subsection "Alternative FOREACH-transfer"
text ‹Required for manual refinements›
lemma transfer_FOREACHoci_plain[refine_transfer]:
assumes A: "set_iterator_genord iterate s ordR"
assumes R: "⋀x σ. RETURN (fi x σ) ≤ f x σ"
shows "RETURN (iterate c fi σ) ≤ FOREACHoci ordR I s c f σ"
proof -
from A obtain l where [simp]:
"distinct l"
"s = set l"
"sorted_wrt ordR l"
"iterate = foldli l"
unfolding set_iterator_genord_def by blast
have "RETURN (foldli l c fi σ) ≤ nfoldli l c f σ"
by (rule nfoldli_transfer_plain[OF R])
also have "… = do { l ← RETURN l; nfoldli l c f σ }" by simp
also have "… ≤ FOREACHoci ordR I s c f σ"
apply (rule refine_IdD)
unfolding FOREACHoci_def
apply refine_rcg
apply simp
apply simp
apply (rule nfoldli_while)
done
finally show ?thesis by simp
qed
lemma transfer_FOREACHoi_plain[refine_transfer]:
assumes A: "set_iterator_genord iterate s ordR"
assumes R: "⋀x σ. RETURN (fi x σ) ≤ f x σ"
shows "RETURN (iterate (λ_. True) fi σ) ≤ FOREACHoi ordR I s f σ"
using assms unfolding FOREACHoi_def by (rule transfer_FOREACHoci_plain)
lemma transfer_FOREACHci_plain[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. RETURN (fi x σ) ≤ f x σ"
shows "RETURN (iterate c fi σ) ≤ FOREACHci I s c f σ"
using assms unfolding FOREACHci_def set_iterator_def
by (rule transfer_FOREACHoci_plain)
lemma transfer_FOREACHi_plain[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. RETURN (fi x σ) ≤ f x σ"
shows "RETURN (iterate (λ_. True) fi σ) ≤ FOREACHi I s f σ"
using assms unfolding FOREACHi_def
by (rule transfer_FOREACHci_plain)
lemma transfer_FOREACHc_plain[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. RETURN (fi x σ) ≤ f x σ"
shows "RETURN (iterate c fi σ) ≤ FOREACHc s c f σ"
using assms unfolding FOREACHc_def
by (rule transfer_FOREACHci_plain)
lemma transfer_FOREACH_plain[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. RETURN (fi x σ) ≤ f x σ"
shows "RETURN (iterate (λ_. True) fi σ) ≤ FOREACH s f σ"
using assms unfolding FOREACH_def
by (rule transfer_FOREACHc_plain)
abbreviation "dres_it iterate c (fi::'a ⇒ 'b ⇒ 'b dres) σ ≡
iterate (case_dres False False c) (λx s. s⤜fi x) (dRETURN σ)"
lemma transfer_FOREACHoci_nres[refine_transfer]:
assumes A: "set_iterator_genord iterate s ordR"
assumes R: "⋀x σ. nres_of (fi x σ) ≤ f x σ"
shows "nres_of (dres_it iterate c fi σ) ≤ FOREACHoci ordR I s c f σ"
proof -
from A obtain l where [simp]:
"distinct l"
"s = set l"
"sorted_wrt ordR l"
"iterate = foldli l"
unfolding set_iterator_genord_def by blast
have "nres_of (dres_it (foldli l) c fi σ) ≤ nfoldli l c f σ"
by (rule nfoldli_transfer_dres[OF R])
also have "… = do { l ← RETURN l; nfoldli l c f σ }" by simp
also have "… ≤ FOREACHoci ordR I s c f σ"
apply (rule refine_IdD)
unfolding FOREACHoci_def
apply refine_rcg
apply simp
apply simp
apply (rule nfoldli_while)
done
finally show ?thesis by simp
qed
lemma transfer_FOREACHoi_nres[refine_transfer]:
assumes A: "set_iterator_genord iterate s ordR"
assumes R: "⋀x σ. nres_of (fi x σ) ≤ f x σ"
shows "nres_of (dres_it iterate (λ_. True) fi σ) ≤ FOREACHoi ordR I s f σ"
using assms unfolding FOREACHoi_def by (rule transfer_FOREACHoci_nres)
lemma transfer_FOREACHci_nres[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. nres_of (fi x σ) ≤ f x σ"
shows "nres_of (dres_it iterate c fi σ) ≤ FOREACHci I s c f σ"
using assms unfolding FOREACHci_def set_iterator_def
by (rule transfer_FOREACHoci_nres)
lemma transfer_FOREACHi_nres[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. nres_of (fi x σ) ≤ f x σ"
shows "nres_of (dres_it iterate (λ_. True) fi σ) ≤ FOREACHi I s f σ"
using assms unfolding FOREACHi_def
by (rule transfer_FOREACHci_nres)
lemma transfer_FOREACHc_nres[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. nres_of (fi x σ) ≤ f x σ"
shows "nres_of (dres_it iterate c fi σ) ≤ FOREACHc s c f σ"
using assms unfolding FOREACHc_def
by (rule transfer_FOREACHci_nres)
lemma transfer_FOREACH_nres[refine_transfer]:
assumes A: "set_iterator iterate s"
assumes R: "⋀x σ. nres_of (fi x σ) ≤ f x σ"
shows "nres_of (dres_it iterate (λ_. True) fi σ) ≤ FOREACH s f σ"
using assms unfolding FOREACH_def
by (rule transfer_FOREACHc_nres)
end
Theory ICF_Autoref
section ‹ICF-setup for Automatic Refinement›
theory ICF_Autoref
imports
ICF_Refine_Monadic
"../GenCF/Intf/Intf_Set"
"../GenCF/Intf/Intf_Map"
begin
subsection ‹Unique Priority Queue›
consts i_prio :: "interface ⇒ interface ⇒ interface"
definition [simp]: "op_uprio_empty ≡ Map.empty"
definition [simp]: "op_uprio_is_empty x ≡ x = Map.empty"
definition [simp]: "op_uprio_insert s e a ≡ s(e ↦ a)"
definition op_uprio_prio :: "('e⇀'a)⇒'e⇀'a"
where [simp]: "op_uprio_prio s e ≡ s e"
context begin interpretation autoref_syn .
lemma uprio_pats:
fixes s :: "'e⇀'a"
shows
"Map.empty::'e⇀'a ≡ op_uprio_empty"
"s e ≡ op_uprio_prio$s$e"
"s(e↦a) ≡ op_uprio_insert$s$e$a"
"dom s = {} ≡ op_uprio_is_empty$s"
"{} = dom s ≡ op_uprio_is_empty$s"
"s=Map.empty ≡ op_uprio_is_empty$s"
"Map.empty=s ≡ op_uprio_is_empty$s"
by (auto intro!: eq_reflection)
end
term prio_pop_min
lemma [autoref_itype]:
"op_uprio_empty ::⇩i ⟨Ie,Ia⟩⇩ii_prio"
"op_uprio_prio ::⇩i ⟨Ie,Ia⟩⇩ii_prio →⇩i Ie →⇩i ⟨Ia⟩⇩ii_option"
"op_uprio_is_empty ::⇩i ⟨Ie,Ia⟩⇩ii_prio →⇩i i_bool"
"op_uprio_insert ::⇩i ⟨Ie,Ia⟩⇩ii_prio →⇩i Ie →⇩i Ia →⇩i ⟨Ie,Ia⟩⇩ii_prio"
"prio_pop_min ::⇩i ⟨Ie,Ia⟩⇩ii_prio →⇩i ⟨⟨Ie,⟨Ia,⟨Ie,Ia⟩⇩ii_prio⟩⇩ii_prod⟩⇩ii_prod⟩⇩ii_nres"
by simp_all
context uprio begin
definition rel_def_internal:
"⋀Re Ra. rel Re Ra ≡ br α invar O (Re → ⟨Ra⟩ option_rel)"
lemma rel_def:
"⋀Re Ra. ⟨Re,Ra⟩rel ≡ br α invar O (Re → ⟨Ra⟩ option_rel)"
by (simp add: rel_def_internal relAPP_def)
lemma rel_id[simp]: "⟨Id,Id⟩rel = br α invar"
by (simp add: rel_def)
lemma rel_sv[relator_props]:
"⋀Re Ra. ⟦Range Re = UNIV; single_valued Ra⟧ ⟹ single_valued (⟨Re,Ra⟩rel)"
unfolding rel_def by tagged_solver
lemmas [autoref_rel_intf] = REL_INTFI[of rel i_prio]
end
lemma (in uprio) rel_alt: "⟨Id,Rv⟩rel =
{ (c,a). ∀x. (α c x,a x)∈⟨Rv⟩option_rel ∧ invar c }"
by (auto simp: rel_def br_def dest: fun_relD)
lemma (in uprio_empty) autoref_empty[autoref_rules]:
"⋀Re Ra. PREFER_id Re ⟹ (empty (),op_uprio_empty)∈⟨Re,Ra⟩rel"
by (auto simp: empty_correct rel_alt)
lemma (in uprio_isEmpty) autoref_is_empty[autoref_rules]:
"⋀Re Ra. PREFER_id Re ⟹ (isEmpty,op_uprio_is_empty)∈⟨Re,Ra⟩rel→bool_rel"
by (auto simp: isEmpty_correct rel_alt intro!: ext)
lemma (in uprio_prio) autoref_prio[autoref_rules]:
"⋀Re Ra. PREFER_id Re ⟹ (prio,op_uprio_prio)∈⟨Re,Ra⟩rel→Re→⟨Ra⟩option_rel"
by (auto simp: prio_correct rel_alt intro!: ext)
lemma (in uprio_insert) autoref_insert[autoref_rules]:
"⋀Re Ra. PREFER_id Re ⟹ (insert,op_uprio_insert)∈⟨Re,Ra⟩rel→Re→Ra→⟨Re,Ra⟩rel"
by (auto simp: insert_correct rel_alt intro!: ext)
lemma (in uprio_pop) autoref_prio_pop_min[autoref_rules]:
"⋀Re Ra. ⟦PREFER_id Re; PREFER_id Ra ⟧
⟹ (λs. RETURN (pop s),prio_pop_min)∈⟨Re,Ra⟩rel→⟨⟨Re,⟨Ra,⟨Re,Ra⟩rel⟩prod_rel⟩prod_rel⟩nres_rel"
apply simp
apply (intro fun_relI nres_relI)
by (rule prio_pop_min_refine)
context set begin
definition rel_def_internal: "rel R ≡ br α invar O ⟨R⟩set_rel"
lemma rel_def: "⟨R⟩rel ≡ br α invar O ⟨R⟩set_rel"
by (simp add: rel_def_internal relAPP_def)
lemma rel_id[simp]: "⟨Id⟩rel = br α invar" by (simp add: rel_def)
lemma rel_sv[relator_props]: "single_valued R ⟹ single_valued (⟨R⟩rel)"
unfolding rel_def by tagged_solver
lemmas [autoref_rel_intf] = REL_INTFI[of rel i_set]
end
context map begin
definition rel_def_internal:
"rel Rk Rv ≡ br α invar O (Rk → ⟨Rv⟩ option_rel)"
lemma rel_def:
"⟨Rk,Rv⟩rel ≡ br α invar O (Rk → ⟨Rv⟩ option_rel)"
by (simp add: rel_def_internal relAPP_def)
lemma rel_id[simp]: "⟨Id,Id⟩rel = br α invar"
by (simp add: rel_def)
lemma rel_sv[relator_props]:
"⟦Range Rk = UNIV; single_valued Rv⟧ ⟹ single_valued (⟨Rk,Rv⟩rel)"
unfolding rel_def
by (tagged_solver (trace))
lemmas [autoref_rel_intf] = REL_INTFI[of rel i_map]
end
setup ‹Revert_Abbrev.revert_abbrev "Autoref_Binding_ICF.*.rel"›
lemma Collect_x_x_pairs_rel_image[simp]: "{p. ∃x. p = (x, x)}``x = x"
by auto
subsection "Set"
lemma (in set_empty) empty_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (empty (), {}) ∈ ⟨Rk⟩rel"
by (simp add: br_def empty_correct)
lemma (in set_memb) memb_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (memb,(∈))∈Rk→⟨Rk⟩rel→Id"
apply simp
by (auto simp add: memb_correct br_def)
lemma (in set_ins) ins_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (ins,Set.insert)∈Rk→⟨Rk⟩rel→⟨Rk⟩rel"
by simp (auto simp add: ins_correct br_def)
context set_ins_dj begin
context begin interpretation autoref_syn .
lemma ins_dj_autoref[autoref_rules]:
assumes "SIDE_PRECOND_OPT (x'∉s')"
assumes "PREFER_id Rk"
assumes "(x,x')∈Rk"
assumes "(s,s')∈⟨Rk⟩rel"
shows "(ins_dj x s,(OP Set.insert ::: Rk → ⟨Rk⟩rel → ⟨Rk⟩rel)$x'$s')∈⟨Rk⟩rel"
using assms
apply simp
apply (auto simp add: ins_dj_correct br_def)
done
end
end
lemma (in set_delete) delete_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (delete,op_set_delete)∈Rk→⟨Rk⟩rel→⟨Rk⟩rel"
by simp (auto simp add: delete_correct op_set_delete_def br_def)
lemma (in set_isEmpty) isEmpty_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (isEmpty,op_set_isEmpty) ∈ ⟨Rk⟩rel→Id"
apply (simp add: br_def)
apply (fastforce simp: isEmpty_correct)
done
lemma (in set_isSng) isSng_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (isSng,op_set_isSng) ∈ ⟨Rk⟩rel→Id"
by simp
(auto simp add: isSng_correct op_set_isSng_def br_def card_Suc_eq)
lemma (in set_ball) ball_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (ball,Set.Ball) ∈ ⟨Rk⟩rel→(Rk→Id)→Id"
by simp (auto simp add: ball_correct fun_rel_def br_def)
lemma (in set_bex) bex_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (bex,Set.Bex) ∈ ⟨Rk⟩rel→(Rk→Id)→Id"
apply simp
apply (auto simp: bex_correct fun_rel_def br_def intro!: ext)
done
lemma (in set_size) size_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (size,card) ∈ ⟨Rk⟩rel → Id"
by simp (auto simp add: size_correct br_def)
lemma (in set_size_abort) size_abort_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (size_abort,op_set_size_abort) ∈ Id → ⟨Rk⟩rel → Id"
by simp
(auto simp add: size_abort_correct op_set_size_abort_def br_def)
lemma (in set_union) union_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (union,(∪))∈⟨Rk⟩s1.rel→⟨Rk⟩s2.rel→⟨Rk⟩s3.rel"
by simp (auto simp add: union_correct br_def)
context set_union_dj begin
context begin interpretation autoref_syn .
lemma union_dj_autoref[autoref_rules]:
assumes "PREFER_id Rk"
assumes "SIDE_PRECOND_OPT (a'∩b'={})"
assumes "(a,a')∈⟨Rk⟩s1.rel"
assumes "(b,b')∈⟨Rk⟩s2.rel"
shows "(union_dj a b,(OP (∪) ::: ⟨Rk⟩s1.rel → ⟨Rk⟩s2.rel → ⟨Rk⟩s3.rel)$a'$b')
∈⟨Rk⟩s3.rel"
using assms
by simp (auto simp: union_dj_correct br_def)
end
end
lemma (in set_diff) diff_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (diff,(-))∈⟨Rk⟩s1.rel→⟨Rk⟩s2.rel→⟨Rk⟩s1.rel"
by simp (auto simp add: diff_correct br_def)
lemma (in set_filter) filter_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (filter,op_set_filter)∈(Rk → Id) → ⟨Rk⟩s1.rel→⟨Rk⟩s2.rel"
by simp (auto simp add: filter_correct op_set_filter_def fun_rel_def
br_def)
lemma (in set_inter) inter_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (inter,(∩))∈⟨Rk⟩s1.rel→⟨Rk⟩s2.rel→⟨Rk⟩s3.rel"
by simp (auto simp add: inter_correct br_def)
lemma (in set_subset) subset_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (subset,(⊆))∈⟨Rk⟩s1.rel→⟨Rk⟩s2.rel→Id"
by simp (auto simp add: subset_correct br_def)
lemma (in set_equal) equal_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (equal,(=))∈⟨Rk⟩s1.rel→⟨Rk⟩s2.rel→Id"
by simp (auto simp add: equal_correct br_def)
lemma (in set_disjoint) disjoint_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (disjoint,op_set_disjoint)∈⟨Rk⟩s1.rel→⟨Rk⟩s2.rel→Id"
by simp (auto simp add: disjoint_correct op_set_disjoint_def br_def)
lemma (in list_to_set) to_set_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (to_set,set)∈⟨Rk⟩list_rel → ⟨Rk⟩rel"
apply simp
apply (auto simp add: to_set_correct br_def)
done
context set_sel' begin
context begin interpretation autoref_syn .
lemma autoref_op_set_pick[autoref_rules]:
assumes "SIDE_PRECOND (s'≠{})"
assumes "PREFER_id Rk"
assumes "(s,s')∈⟨Rk⟩rel"
shows "(RETURN (the (sel' s (λ_. True))),
(OP op_set_pick ::: ⟨Rk⟩rel → ⟨Rk⟩nres_rel) $ s')
∈ ⟨Rk⟩nres_rel"
using assms
apply (clarsimp simp add: br_def nres_rel_def ex_in_conv[symmetric])
apply (erule (1) sel'E[OF _ _ TrueI])
apply (auto intro: RES_refine)
done
end
end
lemma (in poly_set_iteratei) proper[proper_it]:
"proper_it' iteratei iteratei"
apply (rule proper_it'I)
by (rule pi_iteratei)
lemma (in poly_set_iteratei) autoref_iteratei[autoref_ga_rules]:
"REL_IS_ID Rk ⟹ is_set_to_list Rk rel (it_to_list iteratei)"
unfolding is_set_to_list_def is_set_to_sorted_list_def it_to_list_def
it_to_sorted_list_def
apply (simp add: br_def, intro allI impI)
apply (drule iteratei_correct)
unfolding set_iterator_def set_iterator_genord_foldli_conv
apply (elim exE)
apply clarsimp
apply (drule fun_cong[where x="λ_::'x list. True"])
apply simp
done
lemma (in poly_set_iterateoi) proper_o[proper_it]:
"proper_it' iterateoi iterateoi"
apply (rule proper_it'I)
by (rule pi_iterateoi)
lemma (in poly_set_iterateoi) autoref_iterateoi[autoref_ga_rules]:
"REL_IS_ID Rk ⟹
is_set_to_sorted_list (≤) Rk rel (it_to_list iterateoi)"
unfolding is_set_to_sorted_list_def it_to_list_def it_to_sorted_list_def
apply (simp add: br_def, intro allI impI)
apply (drule iterateoi_correct)
unfolding set_iterator_linord_def set_iterator_genord_foldli_conv
apply (elim exE)
apply clarsimp
apply (drule fun_cong[where x="λ_::'x list. True"])
apply simp
done
lemma (in poly_set_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]:
"REL_IS_ID Rk ⟹
is_set_to_sorted_list (≥) Rk rel (it_to_list rev_iterateoi)"
unfolding is_set_to_sorted_list_def it_to_list_def it_to_sorted_list_def
apply (simp add: br_def, intro allI impI)
apply (drule rev_iterateoi_correct)
unfolding set_iterator_rev_linord_def set_iterator_genord_foldli_conv
apply (elim exE)
apply clarsimp
apply (drule fun_cong[where x="λ_::'x list. True"])
apply simp
done
lemma (in poly_set_rev_iterateoi) proper_ro[proper_it]:
"proper_it' rev_iterateoi rev_iterateoi"
apply (rule proper_it'I)
by (rule pi_rev_iterateoi)
subsection "Map"
lemma (in map) rel_alt: "⟨Id,Rv⟩rel =
{ (c,a). ∀x. (α c x,a x)∈⟨Rv⟩option_rel ∧ invar c }"
by (auto simp: rel_def br_def dest: fun_relD)
lemma (in map_empty) empty_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (empty (),op_map_empty)∈⟨Rk,Rv⟩rel"
by (auto simp: empty_correct rel_alt)
lemma (in map_lookup) lookup_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (lookup,op_map_lookup)∈Rk→⟨Rk,Rv⟩rel→⟨Rv⟩option_rel"
apply (intro fun_relI option_relI)
apply (auto simp: lookup_correct rel_alt
dest: fun_relD2)
done
lemma (in map_update) update_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (update,op_map_update)∈Rk→Rv→⟨Rk,Rv⟩rel→⟨Rk,Rv⟩rel"
apply (intro fun_relI)
apply (simp add: update_correct rel_alt)
done
context map_update_dj begin
context begin interpretation autoref_syn .
lemma update_dj_autoref[autoref_rules]:
assumes "SIDE_PRECOND_OPT (k'∉dom m')"
assumes "PREFER_id Rk"
assumes "(k,k')∈Rk"
assumes "(v,v')∈Rv"
assumes "(m,m')∈⟨Rk,Rv⟩rel"
shows "(update_dj k v m,
(OP op_map_update ::: Rk → Rv → ⟨Rk,Rv⟩rel → ⟨Rk,Rv⟩rel)$k'$v'$m'
)∈⟨Rk,Rv⟩rel"
using assms
apply (subgoal_tac "k∉dom (α m)")
apply (simp add: update_dj_correct rel_alt)
apply (auto simp add: rel_alt option_rel_def)
apply (metis option.simps(3))
done
end
end
lemma (in map_delete) delete_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (delete,op_map_delete)∈Rk→⟨Rk,Rv⟩rel→⟨Rk,Rv⟩rel"
apply (intro fun_relI)
apply (simp add: delete_correct restrict_map_def rel_alt)
done
lemma (in map_restrict) restrict_autoref[autoref_rules]:
"PREFER_id Rk ⟹
(restrict,op_map_restrict)
∈ (⟨Rk,Rv⟩prod_rel → Id) → ⟨Rk,Rv⟩m1.rel → ⟨Rk,Rv⟩m2.rel"
apply (intro fun_relI)
apply (simp add: restrict_correct br_comp_alt m1.rel_def m2.rel_def )
apply (intro fun_relI)
apply (auto simp: restrict_map_def split: if_split_asm)
apply (drule (1) fun_relD1)
apply (auto simp: option_rel_def) []
apply (drule (1) fun_relD1)
apply (auto simp: option_rel_def) []
apply (drule (1) fun_relD1)
apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
apply (drule (1) fun_relD2)
apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
done
lemma (in map_add) add_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (add,(++))∈⟨Rk,Rv⟩rel→⟨Rk,Rv⟩rel→⟨Rk,Rv⟩rel"
apply (auto simp add: add_correct rel_alt Map.map_add_def
split: option.split)
apply (drule_tac x=x in spec)+
apply simp
apply (metis option.simps(3) option_rel_simp(2))
by (metis (lifting) option_rel_simp(3))
context map_add_dj begin
context begin interpretation autoref_syn .
lemma add_dj_autoref[autoref_rules]:
assumes "PREFER_id Rk"
assumes "SIDE_PRECOND_OPT (dom a' ∩ dom b' = {})"
assumes "(a,a')∈⟨Rk,Rv⟩rel"
assumes "(b,b')∈⟨Rk,Rv⟩rel"
shows "(add_dj a b, (OP (++) ::: ⟨Rk,Rv⟩rel → ⟨Rk,Rv⟩rel → ⟨Rk,Rv⟩rel) $ a' $ b')∈⟨Rk,Rv⟩rel"
using assms
apply simp
apply (subgoal_tac "dom (α a) ∩ dom (α b) = {}")
apply (clarsimp simp add: add_dj_correct rel_def br_comp_alt)
apply (auto
simp add: rel_def br_comp_alt Map.map_add_def
split: option.split
elim: fun_relE1 dest: fun_relD1 intro: option_relI
) []
apply (clarsimp simp add: rel_def br_comp_alt)
apply (auto simp: dom_def)
apply (drule (1) fun_relD1)
apply (drule (1) fun_relD1)
apply (auto simp: option_rel_def)
done
end
end
lemma (in map_isEmpty) isEmpty_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (isEmpty,op_map_isEmpty)∈⟨Rk,Rv⟩rel→Id"
by (auto simp: isEmpty_correct rel_alt
intro!: ext)
lemma sngI:
assumes "m k = Some v"
assumes "∀k'. k'≠k ⟶ m k' = None"
shows "m = [k↦v]"
using assms
by (auto intro!: ext)
lemma (in map_isSng) isSng_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (isSng,op_map_isSng)∈⟨Rk,Rv⟩rel→Id"
apply (auto simp add: isSng_correct rel_alt)
apply (rule_tac x=k in exI)
apply (rule_tac x="the (a' k)" in exI)
apply (rule sngI)
apply (drule_tac x=k in spec)
apply (auto elim: option_relE) []
apply (force elim: option_relE) []
apply (rule_tac x=k in exI)
apply (rule_tac x="the (α a k)" in exI)
apply (rule sngI)
apply (drule_tac x=k in spec)
apply (auto elim: option_relE) []
apply (force elim: option_relE) []
done
lemma (in map_ball) ball_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (ball,op_map_ball)∈⟨Rk,Rv⟩rel→(⟨Rk,Rv⟩prod_rel→Id)→Id"
apply (auto simp: ball_correct rel_alt map_to_set_def
option_rel_def prod_rel_def fun_rel_def)
apply (metis option.inject option.simps(3))+
done
lemma (in map_bex) bex_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (bex,op_map_bex)∈⟨Rk,Rv⟩rel→(⟨Rk,Rv⟩prod_rel→Id)→Id"
apply (auto simp: bex_correct map_to_set_def rel_alt
option_rel_def prod_rel_def fun_rel_def)
apply (metis option.inject option.simps(3))+
done
lemma (in map_size) size_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (size,op_map_size)∈⟨Rk,Rv⟩rel→Id"
apply (auto simp: size_correct rel_alt option_rel_def dom_def
intro!: arg_cong[where f=card])
apply (metis option.simps(3))+
done
lemma (in map_size_abort) size_abort_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (size_abort,op_map_size_abort)∈Id→⟨Rk,Rv⟩rel→Id"
apply (auto simp: size_abort_correct
rel_alt option_rel_def
dom_def intro!: arg_cong[where f=card] cong[OF arg_cong[where f=min]])
apply (metis option.simps(3))+
done
lemma (in list_to_map) to_map_autoref[autoref_rules]:
"PREFER_id Rk ⟹ (to_map,map_of)∈ ⟨⟨Rk,Rv⟩prod_rel⟩list_rel → ⟨Rk,Rv⟩rel"
proof (intro fun_relI)
fix l :: "('u×'v) list" and l' :: "('u×'a) list"
assume "PREFER_id Rk" hence [simp]: "Rk=Id" by simp
assume "(l,l')∈⟨⟨Rk,Rv⟩prod_rel⟩list_rel"
thus "(to_map l, map_of l') ∈ ⟨Rk,Rv⟩rel"
apply (simp add: list_rel_def)
proof (induct rule: list_all2_induct)
case Nil thus ?case
by (auto simp add: to_map_correct rel_alt)
next
case (Cons x x' l l') thus ?case
by (auto simp add: to_map_correct
rel_alt prod_rel_def)
qed
qed
lemma key_rel_true[simp]: "key_rel (λ_ _. True) = (λ_ _. True)"
by (auto intro!: ext simp: key_rel_def)
lemma (in poly_map_iteratei) proper[proper_it]:
"proper_it' iteratei iteratei"
apply (rule proper_it'I)
by (rule pi_iteratei)
lemma (in poly_map_iteratei) autoref_iteratei[autoref_ga_rules]:
assumes ID: "REL_IS_ID Rk"
"REL_IS_ID Rv"
shows "is_map_to_list Rk Rv rel (it_to_list iteratei)"
proof -
from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all
show ?thesis
unfolding is_map_to_sorted_list_def is_map_to_list_def
it_to_sorted_list_def
apply simp
apply (intro allI impI conjI)
proof -
fix m m'
assume "(m, m') ∈ br α invar"
hence I: "invar m" and M': "m' = α m" by (simp_all add: br_def)
have [simp]: "⋀c. (λ(_,_). c) = (λ_. c)" by auto
from map_it_to_list_genord_correct[where it = iteratei,
where R="λ_ _. True", simplified, OF
iteratei_correct[OF I, unfolded set_iterator_def]
] have
M: "Map.map_of (it_to_list iteratei m) = α m"
and D: "distinct (List.map fst (it_to_list iteratei m))"
by (simp_all)
from D show "distinct (it_to_list iteratei m)"
by (rule distinct_mapI)
from M show "map_to_set m' = set (it_to_list iteratei m)"
by (simp add: M' map_of_map_to_set[OF D])
qed
qed
lemma (in poly_map_iterateoi) proper_o[proper_it]:
"proper_it' iterateoi iterateoi"
apply (rule proper_it'I)
by (rule pi_iterateoi)
lemma (in poly_map_iterateoi) autoref_iterateoi[autoref_ga_rules]:
assumes ID: "REL_IS_ID Rk"
"REL_IS_ID Rv"
shows "is_map_to_sorted_list (≤) Rk Rv rel (it_to_list iterateoi)"
proof -
from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all
show ?thesis
unfolding is_map_to_sorted_list_def
it_to_sorted_list_def
apply simp
apply (intro allI impI conjI)
proof -
fix m m'
assume "(m, m') ∈ br α invar"
hence I: "invar m" and M': "m' = α m" by (simp_all add: br_def)
have [simp]: "⋀c. (λ(_,_). c) = (λ_. c)" by auto
from map_it_to_list_linord_correct[where it = iterateoi,
OF iterateoi_correct[OF I]
] have
M: "map_of (it_to_list iterateoi m) = α m"
and D: "distinct (map fst (it_to_list iterateoi m))"
and S: "sorted (map fst (it_to_list iterateoi m))"
by (simp_all)
from D show "distinct (it_to_list iterateoi m)"
by (rule distinct_mapI)
from M show "map_to_set m' = set (it_to_list iterateoi m)"
by (simp add: M' map_of_map_to_set[OF D])
from S show "sorted_wrt (key_rel (≤)) (it_to_list iterateoi m)"
by (simp add: key_rel_def[abs_def])
qed
qed
lemma (in poly_map_rev_iterateoi) proper_ro[proper_it]:
"proper_it' rev_iterateoi rev_iterateoi"
apply (rule proper_it'I)
by (rule pi_rev_iterateoi)
lemma (in poly_map_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]:
assumes ID: "REL_IS_ID Rk"
"REL_IS_ID Rv"
shows "is_map_to_sorted_list (≥) Rk Rv rel (it_to_list rev_iterateoi)"
proof -
from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all
show ?thesis
unfolding is_map_to_sorted_list_def
it_to_sorted_list_def
apply simp
apply (intro allI impI conjI)
proof -
fix m m'
assume "(m, m') ∈ br α invar"
hence I: "invar m" and M': "m' = α m" by (simp_all add: br_def)
have [simp]: "⋀c. (λ(_,_). c) = (λ_. c)" by auto
from map_it_to_list_rev_linord_correct[where it = rev_iterateoi,
OF rev_iterateoi_correct[OF I]
] have
M: "map_of (it_to_list rev_iterateoi m) = α m"
and D: "distinct (map fst (it_to_list rev_iterateoi m))"
and S: "sorted (rev (map fst (it_to_list rev_iterateoi m)))"
by (simp_all)
from D show "distinct (it_to_list rev_iterateoi m)"
by (rule distinct_mapI)
from M show "map_to_set m' = set (it_to_list rev_iterateoi m)"
by (simp add: M' map_of_map_to_set[OF D])
from S show "sorted_wrt (key_rel (≥)) (it_to_list rev_iterateoi m)"
by (simp add: key_rel_def[abs_def])
qed
qed
end
Theory ICF_Entrypoints_Chapter
theory ICF_Entrypoints_Chapter imports Main begin
text_raw ‹\isasection{Entry Points}›
end
Theory Collections
section ‹\isaheader{Standard Collections}›
theory Collections
imports
ICF_Impl
ICF_Refine_Monadic
ICF_Autoref
DatRef
begin
text ‹
This theory summarizes the components of the Isabelle Collection Framework.
›
end
Theory CollectionsV1
section ‹Backwards Compatibility for Version 1›
theory CollectionsV1
imports Collections
begin
text ‹
This theory defines some stuff to establish (partial) backwards
compatibility with ICF Version 1.
›
attribute_setup locale_witness_add = ‹
Scan.succeed (Locale.witness_add)
› "Add witness for locale instantiation. HACK, use
sublocale or interpretation whereever possible!"
subsection ‹Iterators›
text ‹We define all the monomorphic iterator locales›
subsubsection "Set"
locale set_iteratei = finite_set α invar for α :: "'s ⇒ 'x set" and invar +
fixes iteratei :: "'s ⇒ ('x, 'σ) set_iterator"
assumes iteratei_rule: "invar S ⟹ set_iterator (iteratei S) (α S)"
begin
lemma iteratei_rule_P:
"⟦
invar S;
I (α S) σ0;
!!x it σ. ⟦ c σ; x ∈ it; it ⊆ α S; I it σ ⟧ ⟹ I (it - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ;
!!σ it. ⟦ it ⊆ α S; it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ
⟧ ⟹ P (iteratei S c f σ0)"
apply (rule set_iterator_rule_P [OF iteratei_rule, of S I σ0 c f P])
apply simp_all
done
lemma iteratei_rule_insert_P:
"⟦
invar S;
I {} σ0;
!!x it σ. ⟦ c σ; x ∈ α S - it; it ⊆ α S; I it σ ⟧ ⟹ I (insert x it) (f x σ);
!!σ. I (α S) σ ⟹ P σ;
!!σ it. ⟦ it ⊆ α S; it ≠ α S; ¬ c σ; I it σ ⟧ ⟹ P σ
⟧ ⟹ P (iteratei S c f σ0)"
apply (rule set_iterator_rule_insert_P [OF iteratei_rule, of S I σ0 c f P])
apply simp_all
done
text ‹Versions without break condition.›
lemma iterate_rule_P:
"⟦
invar S;
I (α S) σ0;
!!x it σ. ⟦ x ∈ it; it ⊆ α S; I it σ ⟧ ⟹ I (it - {x}) (f x σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (iteratei S (λ_. True) f σ0)"
apply (rule set_iterator_no_cond_rule_P [OF iteratei_rule, of S I σ0 f P])
apply simp_all
done
lemma iterate_rule_insert_P:
"⟦
invar S;
I {} σ0;
!!x it σ. ⟦ x ∈ α S - it; it ⊆ α S; I it σ ⟧ ⟹ I (insert x it) (f x σ);
!!σ. I (α S) σ ⟹ P σ
⟧ ⟹ P (iteratei S (λ_. True) f σ0)"
apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_rule, of S I σ0 f P])
apply simp_all
done
end
lemma set_iteratei_I :
assumes "⋀s. invar s ⟹ set_iterator (iti s) (α s)"
shows "set_iteratei α invar iti"
proof
fix s
assume invar_s: "invar s"
from assms(1)[OF invar_s] show it_OK: "set_iterator (iti s) (α s)" .
from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
show "finite (α s)" .
qed
locale set_iterateoi = ordered_finite_set α invar
for α :: "'s ⇒ ('u::linorder) set" and invar
+
fixes iterateoi :: "'s ⇒ ('u,'σ) set_iterator"
assumes iterateoi_rule:
"invar s ⟹ set_iterator_linord (iterateoi s) (α s)"
begin
lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar m"
assumes I0: "I (α m) σ0"
assumes IP: "!!k it σ. ⟦
c σ;
k ∈ it;
∀j∈it. k≤j;
∀j∈α m - it. j≤k;
it ⊆ α m;
I it σ
⟧ ⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ α m;
it ≠ {};
¬ c σ;
I it σ;
∀k∈it. ∀j∈α m - it. j≤k
⟧ ⟹ P σ"
shows "P (iterateoi m c f σ0)"
using set_iterator_linord_rule_P [OF iterateoi_rule, OF MINV, of I σ0 c f P,
OF I0 _ IF] IP II
by simp
lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar m"
assumes I0: "I ((α m)) σ0"
assumes IP: "!!k it σ. ⟦ k ∈ it; ∀j∈it. k≤j; ∀j∈(α m) - it. j≤k; it ⊆ (α m); I it σ ⟧
⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (iterateoi m (λ_. True) f σ0)"
apply (rule iterateoi_rule_P [where I = I])
apply (simp_all add: assms)
done
end
lemma set_iterateoi_I :
assumes "⋀s. invar s ⟹ set_iterator_linord (itoi s) (α s)"
shows "set_iterateoi α invar itoi"
proof
fix s
assume invar_s: "invar s"
from assms(1)[OF invar_s] show it_OK: "set_iterator_linord (itoi s) (α s)" .
from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_linord_def]]
show "finite (α s)" by simp
qed
locale set_reverse_iterateoi = ordered_finite_set α invar
for α :: "'s ⇒ ('u::linorder) set" and invar
+
fixes reverse_iterateoi :: "'s ⇒ ('u,'σ) set_iterator"
assumes reverse_iterateoi_rule: "
invar m ⟹ set_iterator_rev_linord (reverse_iterateoi m) (α m)"
begin
lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar m"
assumes I0: "I ((α m)) σ0"
assumes IP: "!!k it σ. ⟦
c σ;
k ∈ it;
∀j∈it. k≥j;
∀j∈(α m) - it. j≥k;
it ⊆ (α m);
I it σ
⟧ ⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ (α m);
it ≠ {};
¬ c σ;
I it σ;
∀k∈it. ∀j∈(α m) - it. j≥k
⟧ ⟹ P σ"
shows "P (reverse_iterateoi m c f σ0)"
using set_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, OF MINV, of I σ0 c f P,
OF I0 _ IF] IP II
by simp
lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar m"
assumes I0: "I ((α m)) σ0"
assumes IP: "!!k it σ. ⟦
k ∈ it;
∀j∈it. k≥j;
∀j∈ (α m) - it. j≥k;
it ⊆ (α m);
I it σ
⟧ ⟹ I (it - {k}) (f k σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (reverse_iterateoi m (λ_. True) f σ0)"
apply (rule reverse_iterateoi_rule_P [where I = I])
apply (simp_all add: assms)
done
end
lemma set_reverse_iterateoi_I :
assumes "⋀s. invar s ⟹ set_iterator_rev_linord (itoi s) (α s)"
shows "set_reverse_iterateoi α invar itoi"
proof
fix s
assume invar_s: "invar s"
from assms(1)[OF invar_s] show it_OK: "set_iterator_rev_linord (itoi s) (α s)" .
from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_rev_linord_def]]
show "finite (α s)" by simp
qed
lemma (in poly_set_iteratei) v1_iteratei_impl:
"set_iteratei α invar iteratei"
by unfold_locales (rule iteratei_correct)
lemma (in poly_set_iterateoi) v1_iterateoi_impl:
"set_iterateoi α invar iterateoi"
by unfold_locales (rule iterateoi_correct)
lemma (in poly_set_rev_iterateoi) v1_reverse_iterateoi_impl:
"set_reverse_iterateoi α invar rev_iterateoi"
by unfold_locales (rule rev_iterateoi_correct)
declare (in poly_set_iteratei) v1_iteratei_impl[locale_witness_add]
declare (in poly_set_iterateoi) v1_iterateoi_impl[locale_witness_add]
declare (in poly_set_rev_iterateoi)
v1_reverse_iterateoi_impl[locale_witness_add]
subsubsection "Map"
locale map_iteratei = finite_map α invar for α :: "'s ⇒ 'u ⇀ 'v" and invar +
fixes iteratei :: "'s ⇒ ('u × 'v,'σ) set_iterator"
assumes iteratei_rule: "invar m ⟹ map_iterator (iteratei m) (α m)"
begin
lemma iteratei_rule_P:
assumes "invar m"
and I0: "I (dom (α m)) σ0"
and IP: "!!k v it σ. ⟦ c σ; k ∈ it; α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (it - {k}) (f (k, v) σ)"
and IF: "!!σ. I {} σ ⟹ P σ"
and II: "!!σ it. ⟦ it ⊆ dom (α m); it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ"
shows "P (iteratei m c f σ0)"
using map_iterator_rule_P [OF iteratei_rule, of m I σ0 c f P]
by (simp_all add: assms)
lemma iteratei_rule_insert_P:
assumes
"invar m"
"I {} σ0"
"!!k v it σ. ⟦ c σ; k ∈ (dom (α m) - it); α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (insert k it) (f (k, v) σ)"
"!!σ. I (dom (α m)) σ ⟹ P σ"
"!!σ it. ⟦ it ⊆ dom (α m); it ≠ dom (α m);
¬ (c σ);
I it σ ⟧ ⟹ P σ"
shows "P (iteratei m c f σ0)"
using map_iterator_rule_insert_P [OF iteratei_rule, of m I σ0 c f P]
by (simp_all add: assms)
lemma iterate_rule_P:
"⟦
invar m;
I (dom (α m)) σ0;
!!k v it σ. ⟦ k ∈ it; α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (it - {k}) (f (k, v) σ);
!!σ. I {} σ ⟹ P σ
⟧ ⟹ P (iteratei m (λ_. True) f σ0)"
using iteratei_rule_P [of m I σ0 "λ_. True" f P]
by fast
lemma iterate_rule_insert_P:
"⟦
invar m;
I {} σ0;
!!k v it σ. ⟦ k ∈ (dom (α m) - it); α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (insert k it) (f (k, v) σ);
!!σ. I (dom (α m)) σ ⟹ P σ
⟧ ⟹ P (iteratei m (λ_. True) f σ0)"
using iteratei_rule_insert_P [of m I σ0 "λ_. True" f P]
by fast
end
lemma map_iteratei_I :
assumes "⋀m. invar m ⟹ map_iterator (iti m) (α m)"
shows "map_iteratei α invar iti"
proof
fix m
assume invar_m: "invar m"
from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (α m)" .
from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
show "finite (dom (α m))" by (simp add: finite_map_to_set)
qed
locale map_iterateoi = ordered_finite_map α invar
for α :: "'s ⇒ ('u::linorder) ⇀ 'v" and invar
+
fixes iterateoi :: "'s ⇒ ('u × 'v,'σ) set_iterator"
assumes iterateoi_rule: "
invar m ⟹ map_iterator_linord (iterateoi m) (α m)"
begin
lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
c σ;
k ∈ it;
∀j∈it. k≤j;
∀j∈dom (α m) - it. j≤k;
α m k = Some v;
it ⊆ dom (α m);
I it σ
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ dom (α m);
it ≠ {};
¬ c σ;
I it σ;
∀k∈it. ∀j∈dom (α m) - it. j≤k
⟧ ⟹ P σ"
shows "P (iterateoi m c f σ0)"
using map_iterator_linord_rule_P [OF iterateoi_rule, of m I σ0 c f P] assms
by simp
lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦ k ∈ it; ∀j∈it. k≤j; ∀j∈dom (α m) - it. j≤k; α m k = Some v; it ⊆ dom (α m); I it σ ⟧
⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (iterateoi m (λ_. True) f σ0)"
using map_iterator_linord_rule_P [OF iterateoi_rule, of m I σ0 "λ_. True" f P] assms
by simp
end
lemma map_iterateoi_I :
assumes "⋀m. invar m ⟹ map_iterator_linord (itoi m) (α m)"
shows "map_iterateoi α invar itoi"
proof
fix m
assume invar_m: "invar m"
from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (α m)" .
from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
show "finite (dom (α m))" by (simp add: finite_map_to_set)
qed
locale map_reverse_iterateoi = ordered_finite_map α invar
for α :: "'s ⇒ ('u::linorder) ⇀ 'v" and invar
+
fixes reverse_iterateoi :: "'s ⇒ ('u × 'v,'σ) set_iterator"
assumes reverse_iterateoi_rule: "
invar m ⟹ map_iterator_rev_linord (reverse_iterateoi m) (α m)"
begin
lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
c σ;
k ∈ it;
∀j∈it. k≥j;
∀j∈dom (α m) - it. j≥k;
α m k = Some v;
it ⊆ dom (α m);
I it σ
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
assumes II: "!!σ it. ⟦
it ⊆ dom (α m);
it ≠ {};
¬ c σ;
I it σ;
∀k∈it. ∀j∈dom (α m) - it. j≥k
⟧ ⟹ P σ"
shows "P (reverse_iterateoi m c f σ0)"
using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I σ0 c f P] assms
by simp
lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
assumes MINV: "invar m"
assumes I0: "I (dom (α m)) σ0"
assumes IP: "!!k v it σ. ⟦
k ∈ it;
∀j∈it. k≥j;
∀j∈dom (α m) - it. j≥k;
α m k = Some v;
it ⊆ dom (α m);
I it σ
⟧ ⟹ I (it - {k}) (f (k, v) σ)"
assumes IF: "!!σ. I {} σ ⟹ P σ"
shows "P (reverse_iterateoi m (λ_. True) f σ0)"
using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I σ0 "λ_. True" f P] assms
by simp
end
lemma map_reverse_iterateoi_I :
assumes "⋀m. invar m ⟹ map_iterator_rev_linord (ritoi m) (α m)"
shows "map_reverse_iterateoi α invar ritoi"
proof
fix m
assume invar_m: "invar m"
from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (α m)" .
from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
show "finite (dom (α m))" by (simp add: finite_map_to_set)
qed
lemma (in poly_map_iteratei) v1_iteratei_impl:
"map_iteratei α invar iteratei"
by unfold_locales (rule iteratei_correct)
lemma (in poly_map_iterateoi) v1_iterateoi_impl:
"map_iterateoi α invar iterateoi"
by unfold_locales (rule iterateoi_correct)
lemma (in poly_map_rev_iterateoi) v1_reverse_iterateoi_impl:
"map_reverse_iterateoi α invar rev_iterateoi"
by unfold_locales (rule rev_iterateoi_correct)
declare (in poly_map_iteratei) v1_iteratei_impl[locale_witness_add]
declare (in poly_map_iterateoi) v1_iterateoi_impl[locale_witness_add]
declare (in poly_map_rev_iterateoi)
v1_reverse_iterateoi_impl[locale_witness_add]
subsection ‹Concrete Operation Names›
text ‹We define abbreviations to recover the ‹xx_op›-names›
local_setup ‹let
val thy = @{theory}
val ctxt = Proof_Context.init_global thy;
val pats = [
"hs","hm",
"rs","rm",
"ls","lm","lsi","lmi","lsnd","lss",
"ts","tm",
"ias","iam",
"ahs","ahm",
"bino",
"fifo",
"ft",
"alprioi",
"aluprioi",
"skew"
];
val {const_space, constants, ...} = Sign.consts_of thy |> Consts.dest
val clist = Name_Space.extern_entries true ctxt const_space constants |> map (apfst #1)
fun abbrevs_for pat = clist
|> map_filter (fn (n,_) => case Long_Name.explode n of
[_,prefix,opname] =>
if prefix = pat then let
val aname = prefix ^ "_" ^ opname
val rhs = Proof_Context.read_term_abbrev ctxt n
in SOME (aname,rhs) end
else NONE
| _ => NONE);
fun do_abbrevs pat lthy = let
val abbrevs = abbrevs_for pat;
in
case abbrevs of [] => (warning ("No stuff found for "^pat); lthy)
| _ => let
val lthy = fold (fn (name,rhs) =>
Local_Theory.abbrev
Syntax.mode_input
((Binding.name name,NoSyn),rhs) #> #2
) abbrevs lthy
in lthy end
end
in
fold do_abbrevs pats
end
›
lemmas hs_correct = hs.correct
lemmas hm_correct = hm.correct
lemmas rs_correct = rs.correct
lemmas rm_correct = rm.correct
lemmas ls_correct = ls.correct
lemmas lm_correct = lm.correct
lemmas lsi_correct = lsi.correct
lemmas lmi_correct = lmi.correct
lemmas lsnd_correct = lsnd.correct
lemmas lss_correct = lss.correct
lemmas ts_correct = ts.correct
lemmas tm_correct = tm.correct
lemmas ias_correct = ias.correct
lemmas iam_correct = iam.correct
lemmas ahs_correct = ahs.correct
lemmas ahm_correct = ahm.correct
lemmas bino_correct = bino.correct
lemmas fifo_correct = fifo.correct
lemmas ft_correct = ft.correct
lemmas alprioi_correct = alprioi.correct
lemmas aluprioi_correct = aluprioi.correct
lemmas skew_correct = skew.correct
locale list_enqueue = list_appendr
locale list_dequeue = list_removel
locale list_push = list_appendl
locale list_pop = list_remover
locale list_top = list_leftmost
locale list_bot = list_rightmost
instantiation rbt :: ("{equal,linorder}",equal) equal
begin
definition "equal_class.equal (r :: ('a, 'b) rbt) r'
== RBT.impl_of r = RBT.impl_of r'"
instance
apply intro_classes
apply (simp add: equal_rbt_def RBT.impl_of_inject)
done
end
end
Theory Collections_Entrypoints_Chapter
theory Collections_Entrypoints_Chapter imports Main begin
text_raw ‹\isachapter{Entry Points}›
text_raw ‹\isasection{Entry Points}›
text ‹
This chapter describes the overall entrypoints to the combination of
Automatic Refinement Framework, Monadic Refinement Framework, and
Collection Framework. These are the theories a typical algorithm development
should be based on.
›
end
Theory Refine_Dflt
section ‹\isaheader{Default Setup}›
theory Refine_Dflt
imports
Refine_Monadic.Refine_Monadic
"GenCF/GenCF"
"Lib/Code_Target_ICF"
begin
text ‹Configurations›
lemmas tyrel_dflt_nat_set =
ty_REL[where 'a="nat set" and R="⟨Id⟩dflt_rs_rel"]
lemmas tyrel_dflt_bool_set =
ty_REL[where 'a="bool set" and R="⟨Id⟩list_set_rel"]
lemmas tyrel_dflt_nat_map =
ty_REL[where R="⟨nat_rel,Rv⟩dflt_rm_rel"] for Rv
lemmas tyrel_dflt_old = tyrel_dflt_nat_set tyrel_dflt_bool_set tyrel_dflt_nat_map
lemmas tyrel_dflt_linorder_set =
ty_REL[where R="⟨Id::('a::linorder×'a) set⟩dflt_rs_rel"]
lemmas tyrel_dflt_linorder_map =
ty_REL[where R="⟨Id::('a::linorder×'a) set,R⟩dflt_rm_rel"] for R
lemmas tyrel_dflt_bool_map =
ty_REL[where R="⟨Id::(bool×bool) set,R⟩list_map_rel"] for R
lemmas tyrel_dflt = tyrel_dflt_linorder_set tyrel_dflt_bool_set tyrel_dflt_linorder_map tyrel_dflt_bool_map
declare tyrel_dflt[autoref_tyrel]
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "Gen-AHM-map-hashable"
@{term "⟨Rk::(_×_::hashable) set,Rv⟩ahm_rel bhc"} PR_LAST #>
declare_prio "Gen-RBT-map-linorder"
@{term "⟨Rk::(_×_::linorder) set,Rv⟩rbt_map_rel lt"} PR_LAST #>
declare_prio "Gen-AHM-map" @{term "⟨Rk,Rv⟩ahm_rel bhc"} PR_LAST #>
declare_prio "Gen-RBT-map" @{term "⟨Rk,Rv⟩rbt_map_rel lt"} PR_LAST
end
›
text "Fallbacks"
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "Gen-List-Set" @{term "⟨R⟩list_set_rel"} PR_LAST #>
declare_prio "Gen-List-Map" @{term "⟨R⟩list_map_rel"} PR_LAST
end
›
text ‹Quick test of setup:›
context begin
private schematic_goal test_dflt_tyrel1: "(?c::?'c,{1,2,3::int})∈?R"
by autoref
private lemmas asm_rl[of "_∈⟨int_rel⟩dflt_rs_rel", OF test_dflt_tyrel1]
private schematic_goal test_dflt_tyrel2: "(?c::?'c,{True, False})∈?R"
by autoref
private lemmas asm_rl[of "_∈⟨bool_rel⟩list_set_rel", OF test_dflt_tyrel2]
private schematic_goal test_dflt_tyrel3: "(?c::?'c,[1::int↦0::nat])∈?R"
by autoref
private lemmas asm_rl[of "_∈⟨int_rel,nat_rel⟩dflt_rm_rel", OF test_dflt_tyrel3]
private schematic_goal test_dflt_tyrel4: "(?c::?'c,[False↦0::nat])∈?R"
by autoref
private lemmas asm_rl[of "_∈⟨bool_rel,nat_rel⟩list_map_rel", OF test_dflt_tyrel4]
end
end
Theory Refine_Dflt_ICF
section ‹\isaheader{Entry Point with genCF and original ICF}›
theory Refine_Dflt_ICF
imports
Refine_Monadic.Refine_Monadic
"GenCF/GenCF"
"ICF/Collections"
"Lib/Code_Target_ICF"
begin
text ‹Contains the Monadic Refinement Framework, the generic collection
framework and the original Isabelle Collection Framework›
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "Gen-RBT-set" @{term "⟨R⟩dflt_rs_rel"} PR_LAST #>
declare_prio "RBT-set" @{term "⟨R⟩rs.rel"} PR_LAST #>
declare_prio "Hash-set" @{term "⟨R⟩hs.rel"} PR_LAST #>
declare_prio "List-set" @{term "⟨R⟩lsi.rel"} PR_LAST
end
›
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "RBT-map" @{term "⟨Rk,Rv⟩rm.rel"} PR_LAST #>
declare_prio "Hash-map" @{term "⟨Rk,Rv⟩hm.rel"} PR_LAST #>
declare_prio "List-map" @{term "⟨Rk,Rv⟩lmi.rel"} PR_LAST
end
›
text "Fallbacks"
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "Gen-List-Set" @{term "⟨R⟩list_set_rel"} PR_LAST #>
declare_prio "Gen-List-Map" @{term "⟨Rk,Rv⟩list_map_rel"} PR_LAST
end
›
class id_refine
instance nat :: id_refine ..
instance bool :: id_refine ..
instance int :: id_refine ..
lemmas [autoref_tyrel] =
ty_REL[where 'a="nat" and R="nat_rel"]
ty_REL[where 'a="int" and R="int_rel"]
ty_REL[where 'a="bool" and R="bool_rel"]
lemmas [autoref_tyrel] =
ty_REL[where 'a="nat set" and R="⟨Id⟩rs.rel"]
ty_REL[where 'a="int set" and R="⟨Id⟩rs.rel"]
ty_REL[where 'a="bool set" and R="⟨Id⟩lsi.rel"]
lemmas [autoref_tyrel] =
ty_REL[where 'a="(nat ⇀ 'b)", where R="⟨nat_rel,Rv⟩dflt_rm_rel"]
ty_REL[where 'a="(int ⇀ 'b)", where R="⟨int_rel,Rv⟩dflt_rm_rel"]
ty_REL[where 'a="(bool ⇀ 'b)", where R="⟨bool_rel,Rv⟩dflt_rm_rel"]
for Rv
lemmas [autoref_tyrel] =
ty_REL[where 'a="(nat ⇀ 'b::id_refine)", where R="⟨nat_rel,Id⟩rm.rel"]
ty_REL[where 'a="(int ⇀ 'b::id_refine)", where R="⟨int_rel,Id⟩rm.rel"]
ty_REL[where 'a="(bool ⇀ 'b::id_refine)", where R="⟨bool_rel,Id⟩rm.rel"]
end
Theory Refine_Dflt_Only_ICF
section ‹\isaheader{Entry Point with only the ICF}›
theory Refine_Dflt_Only_ICF
imports
Refine_Monadic.Refine_Monadic
"ICF/Collections"
"Lib/Code_Target_ICF"
begin
text ‹Contains the Monadic Refinement Framework and the original
Isabelle Collection Framework. The generic collection framework is
not included›
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "RBT-set" @{term "⟨R⟩rs.rel"} PR_LAST #>
declare_prio "Hash-set" @{term "⟨R⟩hs.rel"} PR_LAST #>
declare_prio "List-set" @{term "⟨R⟩lsi.rel"} PR_LAST
end
›
local_setup ‹
let open Autoref_Fix_Rel in
declare_prio "RBT-map" @{term "⟨Rk,Rv⟩rm.rel"} PR_LAST #>
declare_prio "Hash-map" @{term "⟨Rk,Rv⟩hm.rel"} PR_LAST #>
declare_prio "List-map" @{term "⟨Rk,Rv⟩lmi.rel"} PR_LAST
end
›
end
Theory Userguides_Chapter
theory Userguides_Chapter imports Main begin
text_raw ‹\isachapter{Userguides}›
text ‹
This chapter contains various userguides.
›
end
Theory Refine_Monadic_Userguide
theory Refine_Monadic_Userguide
imports "../Refine_Dflt_Only_ICF"
begin
text_raw ‹\isasection{Old Monadic Refinement Framework Userguide}›
section ‹Introduction›
text ‹
This is the old userguide from Refine-Monadic. It contains the
manual approach of using the mondaic refinement framework with the
Isabelle Collection Framework. An alternative, more simple approach is
provided by the Automatic Refinement Framework and the
Generic Collection Framework.
The Isabelle/HOL refinement framework is a library that supports
program and data refinement.
Programs are specified using a nondeterminism monad:
An element of the monad type is either a set of results, or
the special element @{term "FAIL"}, that indicates a failed assertion.
The bind-operation of the monad applies a function to all elements of the
result-set, and joins all possible results.
On the monad type, an ordering ‹≤› is defined, that is lifted subset
ordering, where @{term "FAIL"} is the greatest element. Intuitively,
@{term "S≤S'"} means that program ‹S› refines program ‹S'›,
i.e., all results of ‹S› are also results of ‹S'›, and
‹S› may only fail if ‹S'› also fails.
›
section ‹Guided Tour›
text ‹
In this section, we provide a small example program development in our
framework. All steps of the development are heavily commented.
›
subsection ‹Defining Programs›
text ‹
A program is defined using the Haskell-like do-notation, that is provided by
the Isabelle/HOL library. We start with a simple example, that iterates
over a set of numbers, and computes the maximum value and the sum of
all elements.
›
definition sum_max :: "nat set ⇒ (nat×nat) nres" where
"sum_max V ≡ do {
(_,s,m) ← WHILE (λ(V,s,m). V≠{}) (λ(V,s,m). do {
x←SPEC (λx. x∈V);
let V=V-{x};
let s=s+x;
let m=max m x;
RETURN (V,s,m)
}) (V,0,0);
RETURN (s,m)
}"
text ‹
The type of the nondeterminism monad is @{typ "'a nres"}, where @{typ "'a"}
is the type of the results. Note that this program has only one possible
result, however, the order in which we iterate over the elements of the set
is unspecified.
This program uses the following statements provided by our framework:
While-loops, bindings, return, and specification. We briefly explain the
statements here. A complete reference can be found in
Section~\ref{sec:stmt_ref}.
A while-loop has the form @{term "WHILE b f σ⇩0"}, where @{term "b"} is the
continuation condition, @{term "f"} is the loop body, and @{term "σ⇩0"} is
the initial state. In our case, the state used for the loop is a triple
@{term "(V,s,m)"}, where @{term "V"} is the set of remaining elements,
@{term "s"} is the sum of the elements seen so far, and @{term "m"} is
the maximum of the elements seen so far.
The @{term "WHILE b f σ⇩0"} construct describes a partially correct loop,
i.e., it describes only those results that can be reached by finitely many
iterations, and ignores infinite paths of the loop. In order to
prove total correctness, the construct @{term "WHILE⇩T b f σ⇩0"} is used. It
fails if there exists an infinite execution of the loop.
A binding @{term [source] "do {x←(S⇩1::'a nres); S⇩2}"} nondeterministically
chooses a result of
@{term "S⇩1"}, binds it to variable @{term "x"}, and then continues with
@{term "S⇩2"}. If @{term "S⇩1"} is @{const "FAIL"}, the
bind statement also fails.
The syntactic form @{term [source] "do { let x=V; (S::'a ⇒ 'b nres)}"}
assigns the value ‹V› to variable ‹x›, and continues with
‹S›.
The return statement @{term "RETURN x"} specifies precisely the result
‹x›.
The specification statement @{term "SPEC Φ"} describes all results that
satisfy the predicate ‹Φ›. This is the source of nondeterminism in
programs, as there may be more than one such result. In our case, we describe
any element of set ‹V›.
Note that these statement are shallowly embedded into Isabelle/HOL, i.e.,
they are ordinary Isabelle/HOL constants. The main advantage is, that any
other construct and datatype from Isabelle/HOL may be used inside programs.
In our case, we use Isabelle/HOL's predefined operations on sets and natural
numbers. Another advantage is that extending the framework with new commands
becomes fairly easy.
›
subsection ‹Proving Programs Correct›
text ‹
The next step in the program development is to prove the program correct
w.r.t.\ a specification. In refinement notion, we have to prove that the
program ‹S› refines a specification ‹Φ› if the precondition
‹Ψ› holds, i.e., @{term "Ψ ⟹ S ≤ SPEC Φ"}.
For our purposes, we prove that @{const "sum_max"} really computes the sum
and the maximum.
›
text ‹
As usual, we have to think of a loop invariant first. In our case, this
is rather straightforward. The main complication is introduced by the
partially defined ‹Max›-operator of the Isabelle/HOL standard library.
›
definition "sum_max_invar V⇩0 ≡ λ(V,s::nat,m).
V⊆V⇩0
∧ s=∑(V⇩0-V)
∧ m=(if (V⇩0-V)={} then 0 else Max (V⇩0-V))
∧ finite (V⇩0-V)"
text ‹
We have extracted the most complex verification condition
--- that the invariant is preserved by the loop body --- to
an own lemma. For complex proofs, it is always a good idea to do that,
as it makes the proof more readable.
›
lemma sum_max_invar_step:
assumes "x∈V" "sum_max_invar V⇩0 (V,s,m)"
shows "sum_max_invar V⇩0 (V-{x},s+x,max m x)"
txt ‹In our case the proof is rather straightforward, it only
requires the lemma @{thm [source] it_step_insert_iff}, that handles
the @{term "(V⇩0-(V-{x}))"} terms that occur in the invariant.›
using assms unfolding sum_max_invar_def by (auto simp: it_step_insert_iff)
text ‹
The correctness is now proved by first invoking the verification condition
generator, and then discharging the verification conditions by
‹auto›. Note that we have to apply the
@{thm [source] sum_max_invar_step} lemma, {\em before} we unfold the
definition of the invariant to discharge the remaining verification
conditions.
›
theorem sum_max_correct:
assumes PRE: "V≠{}"
shows "sum_max V ≤ SPEC (λ(s,m). s=∑V ∧ m=Max V)"
txt ‹
The precondition ‹V≠{}› is necessary, as the
‹Max›-operator from Isabelle/HOL's standard library is not defined
for empty sets.
›
using PRE unfolding sum_max_def
apply (intro WHILE_rule[where I="sum_max_invar V"] refine_vcg)
txt ‹Note that we have explicitely instantiated
the rule for the while-loop with the invariant. If this is not done,
the verification condition generator will stop at the WHILE-loop.
›
apply (auto intro: sum_max_invar_step)
unfolding sum_max_invar_def
apply (auto)
done
text ‹
In this proof, we specified the invariant explicitely.
Alternatively, we may annotate the invariant at the while loop,
using the syntax @{term "WHILE⇗I⇖ b f σ⇩0"}. Then, the verification condition
generator will use the annotated invariant automatically.
›
text_raw‹\paragraph{Total Correctness}›
text ‹
Now, we reformulate our program to use a total correct while loop,
and annotate the invariant at the loop. The invariant is strengthened by
stating that the set of elements is finite.
›
definition "sum_max'_invar V⇩0 σ ≡
sum_max_invar V⇩0 σ
∧ (let (V,_,_)=σ in finite (V⇩0-V))"
definition sum_max' :: "nat set ⇒ (nat×nat) nres" where
"sum_max' V ≡ do {
(_,s,m) ← WHILE⇩T⇗sum_max'_invar V⇖ (λ(V,s,m). V≠{}) (λ(V,s,m). do {
x←SPEC (λx. x∈V);
let V=V-{x};
let s=s+x;
let m=max m x;
RETURN (V,s,m)
}) (V,0,0);
RETURN (s,m)
}"
theorem sum_max'_correct:
assumes NE: "V≠{}" and FIN: "finite V"
shows "sum_max' V ≤ SPEC (λ(s,m). s=∑V ∧ m=Max V)"
using NE FIN unfolding sum_max'_def
apply (intro refine_vcg)
txt ‹This time, the verification condition generator uses the annotated
invariant. Moreover, it leaves us with a variant. We have to specify a
well-founded relation, and show that the loop body respects this
relation. In our case, the set ‹V› decreases in each step, and
is initially finite. We use the relation @{const "finite_psubset"} and the
@{const "inv_image"} combinator from the Isabelle/HOL standard library.›
apply (subgoal_tac "wf (inv_image finite_psubset fst)",
assumption)
apply simp
unfolding sum_max'_invar_def
apply (auto intro: sum_max_invar_step)
unfolding sum_max_invar_def
apply (auto intro: finite_subset)
done
subsection ‹Refinement›
text ‹
The next step in the program development is to refine the initial program
towards an executable program. This usually involves both, program refinement
and data refinement. Program refinement means changing the structure of the
program. Usually, some specification statements are replaced by more concrete
implementations. Data refinement means changing the used data types towards
implementable data types.
In our example, we implement the set ‹V› with a distinct list,
and replace the specification statement @{term "SPEC (λx. x∈V)"} by
the head operation on distinct lists. For the lists, we use
the list-set data structure provided by the Isabelle Collection Framework
\cite{L09_collections,LL10}.
For this example, we write the refined program ourselves.
An automation of this task can be achieved with the automatic refinement tool,
which is available as a prototype in Refine-Autoref. Usage examples are in
ex/Automatic-Refinement.
›
definition sum_max_impl :: "nat ls ⇒ (nat×nat) nres" where
"sum_max_impl V ≡ do {
(_,s,m) ← WHILE (λ(V,s,m). ¬ls.isEmpty V) (λ(V,s,m). do {
x←RETURN (the (ls.sel V (λx. True)));
let V=ls.delete x V;
let s=s+x;
let m=max m x;
RETURN (V,s,m)
}) (V,0,0);
RETURN (s,m)
}"
text ‹
Note that we replaced the operations on sets by the respective operations
on lists (with the naming scheme ‹ls.xxx›). The specification
statement was replaced by @{term "the (ls.sel V (λx. True))"}, i.e.,
selection of an element that satisfies the predicate @{term "(λx. True)"}.
As @{const "ls.sel"} returns an option datatype, we extract the value with
@{const "the"}. Moreover, we omitted the loop invariant, as we don't need it
any more.
›
text ‹
Next, we have to show that our concrete pogram actually refines
the abstract one.
›
theorem sum_max_impl_refine:
assumes "(V,V')∈build_rel ls.α ls.invar"
shows "sum_max_impl V ≤ ⇓Id (sum_max V')"
txt ‹
Let ‹R› be a
{\em refinement relation\footnote{Also called coupling invariant.}},
that relates concrete and abstract values.
Then, the function @{term "⇓R"} maps a result-set over abstract values to
the greatest result-set over concrete values that is compatible
w.r.t.\ ‹R›. The value @{const "FAIL"} is mapped to itself.
Thus, the proposition @{term "S ≤ ⇓R S'"} means, that ‹S› refines
‹S'› w.r.t.\ ‹R›, i.e., every value in the result of
‹S› can be abstracted to a value in the result of ‹S'›.
Usually, the refinement relation consists of an invariant ‹I› and
an abstraction function ‹α›. In this case, we may use the
@{term "build_rel I α"}-function to define the refinement relation.
In our example, we assume that the input is in the refinement relation
specified by list-sets, and show that the output is in the identity
relation. We use the identity here, as we do not change the datatypes of
the output.
›
txt ‹The proof is done automatically by the refinement verification
condition generator.
Note that the theory ‹Collection_Bindings› sets up all the
necessary lemmas to discharge refinement conditions for the collection
framework.›
using assms unfolding sum_max_impl_def sum_max_def
apply (refine_rcg)
apply (refine_dref_type)
apply (auto simp add:
ls.correct refine_hsimp refine_rel_defs)
done
text ‹
Refinement is transitive, so it is easy to show that the concrete
program meets the specification.
›
theorem sum_max_impl_correct:
assumes "(V,V')∈build_rel ls.α ls.invar" and "V'≠{}"
shows "sum_max_impl V ≤ SPEC (λ(s,m). s=∑V' ∧ m=Max V')"
proof -
note sum_max_impl_refine
also note sum_max_correct
finally show ?thesis using assms .
qed
text ‹
Just for completeness, we also refine the total correct program in the
same way.
›
definition sum_max'_impl :: "nat ls ⇒ (nat×nat) nres" where
"sum_max'_impl V ≡ do {
(_,s,m) ← WHILE⇩T (λ(V,s,m). ¬ls.isEmpty V) (λ(V,s,m). do {
x←RETURN (the (ls.sel V (λx. True)));
let V=ls.delete x V;
let s=s+x;
let m=max m x;
RETURN (V,s,m)
}) (V,0,0);
RETURN (s,m)
}"
theorem sum_max'_impl_refine:
"(V,V')∈build_rel ls.α ls.invar ⟹ sum_max'_impl V ≤ ⇓Id (sum_max' V')"
unfolding sum_max'_impl_def sum_max'_def
apply refine_rcg
apply refine_dref_type
apply (auto simp: refine_hsimp ls.correct refine_rel_defs)
done
theorem sum_max'_impl_correct:
assumes "(V,V')∈build_rel ls.α ls.invar" and "V'≠{}"
shows "sum_max'_impl V ≤ SPEC (λ(s,m). s=∑V' ∧ m=Max V')"
using ref_two_step[OF sum_max'_impl_refine sum_max'_correct] assms
txt ‹Note that we do not need the finiteness precondition, as list-sets are
always finite. However, in order to exploit this, we have to
unfold the ‹build_rel› construct, that relates the list-set on
the concrete side to the set on the abstract side.
›
apply (auto simp: build_rel_def)
done
subsection ‹Code Generation›
text ‹
In order to generate code from the above definitions,
we convert the function defined in our monad to an ordinary, deterministic
function, for that the Isabelle/HOL code generator can generate code.
For partial correct algorithms, we can generate code inside a deterministic
result monad. The domain of this monad is a flat complete lattice, where
top means a failed assertion and bottom means nontermination. (Note that
executing a function in this monad will never return bottom,
but just diverge).
The construct @{term "nres_of x"} embeds the deterministic into the
nondeterministic monad.
Thus, we have to construct a function ‹?sum_max_code› such that:
›
schematic_goal sum_max_code_aux: "nres_of ?sum_max_code ≤ sum_max_impl V"
txt ‹This is done automatically by the transfer procedure of
our framework.›
unfolding sum_max_impl_def
apply (refine_transfer)
done
text ‹
In order to define the function from the above lemma, we can use the
command ‹concrete_definition›, that is provided by our framework:
›
concrete_definition sum_max_code for V uses sum_max_code_aux
text ‹This defines a new constant ‹sum_max_code›:›
thm sum_max_code_def
text ‹And proves the appropriate refinement lemma:›
thm sum_max_code.refine
text ‹Note that the ‹concrete_definition› command is sensitive to
patterns of the form ‹RETURN _› and ‹nres_of›, in which case
the defined constant will not contain the ‹RETURN›
or ‹nres_of›. In any other case, the defined constant will just be
the left hand side of the refinement statement.
›
text ‹Finally, we can prove a correctness statement that is independent
from our refinement framework:›
theorem sum_max_code_correct:
assumes "ls.α V ≠ {}"
shows "sum_max_code V = dRETURN (s,m) ⟹ s=∑(ls.α V) ∧ m=Max (ls.α V)"
and "sum_max_code V ≠ dFAIL"
txt ‹The proof is done by transitivity, and unfolding some
definitions:›
using nres_correctD[OF order_trans[OF sum_max_code.refine sum_max_impl_correct,
of V "ls.α V"]] assms
by (auto simp: refine_rel_defs)
text ‹For total correctness, the approach is the same. The
only difference is, that we use @{const "RETURN"} instead
of @{const "nres_of"}:›
schematic_goal sum_max'_code_aux:
"RETURN ?sum_max'_code ≤ sum_max'_impl V"
unfolding sum_max'_impl_def
apply (refine_transfer)
done
concrete_definition sum_max'_code for V uses sum_max'_code_aux
theorem sum_max'_code_correct:
"⟦ls.α V ≠ {}⟧ ⟹ sum_max'_code V = (∑(ls.α V), Max (ls.α V))"
using order_trans[OF sum_max'_code.refine sum_max'_impl_correct,
of V "ls.α V"]
by (auto simp: refine_rel_defs)
text ‹
If we use recursion combinators, a plain function can only be generated,
if the recursion combinators can be defined. Alternatively, for total correct
programs, we may generate a (plain) function that internally uses the
deterministic monad, and then extracts the result.
›
schematic_goal sum_max''_code_aux:
"RETURN ?sum_max''_code ≤ sum_max'_impl V"
unfolding sum_max'_impl_def
apply (refine_transfer the_resI)
done
concrete_definition sum_max''_code for V uses sum_max''_code_aux
theorem sum_max''_code_correct:
"⟦ls.α V ≠ {}⟧ ⟹ sum_max''_code V = (∑(ls.α V), Max (ls.α V))"
using order_trans[OF sum_max''_code.refine sum_max'_impl_correct,
of V "ls.α V"]
by (auto simp: refine_rel_defs)
text ‹Now, we can generate verified code with the Isabelle/HOL code
generator:›
export_code sum_max_code sum_max'_code sum_max''_code checking SML
export_code sum_max_code sum_max'_code sum_max''_code checking OCaml?
export_code sum_max_code sum_max'_code sum_max''_code checking Haskell?
export_code sum_max_code sum_max'_code sum_max''_code checking Scala
subsection ‹Foreach-Loops›
text ‹
In the ‹sum_max› example above, we used a while-loop to iterate over
the elements of a set. As this pattern is used commonly, there is
an abbreviation for it in the refinement framework. The construct
@{term "FOREACH S f σ⇩0"} iterates ‹f::'x⇒'s⇒'s› for each element
in ‹S::'x set›, starting with state ‹σ⇩0::'s›.
With foreach-loops, we could have written our example as follows:
›
definition sum_max_it :: "nat set ⇒ (nat×nat) nres" where
"sum_max_it V ≡ FOREACH V (λx (s,m). RETURN (s+x,max m x)) (0,0)"
theorem sum_max_it_correct:
assumes PRE: "V≠{}" and FIN: "finite V"
shows "sum_max_it V ≤ SPEC (λ(s,m). s=∑V ∧ m=Max V)"
using PRE unfolding sum_max_it_def
apply (intro FOREACH_rule[where I="λit σ. sum_max_invar V (it,σ)"] refine_vcg)
apply (rule FIN)
apply (auto intro: sum_max_invar_step)
unfolding sum_max_invar_def
apply (auto)
done
definition sum_max_it_impl :: "nat ls ⇒ (nat×nat) nres" where
"sum_max_it_impl V ≡ FOREACH (ls.α V) (λx (s,m). RETURN (s+x,max m x)) (0,0)"
text ‹Note: The nondeterminism for iterators is currently resolved at
transfer phase, where they are replaced by iterators from the ICF.›
lemma sum_max_it_impl_refine:
notes [refine] = inj_on_id
assumes "(V,V')∈build_rel ls.α ls.invar"
shows "sum_max_it_impl V ≤ ⇓Id (sum_max_it V')"
unfolding sum_max_it_impl_def sum_max_it_def
txt ‹Note that we specified ‹inj_on_id› as additional introduction
rule. This is due to the very general iterator refinement rule, that may
also change the set over that is iterated.›
using assms
apply refine_rcg
apply (auto simp: refine_hsimp refine_rel_defs)
done
schematic_goal sum_max_it_code_aux:
"RETURN ?sum_max_it_code ≤ sum_max_it_impl V"
unfolding sum_max_it_impl_def
apply (refine_transfer)
done
text ‹Note that the transfer method has replaced the iterator by an iterator
from the Isabelle Collection Framework.›
thm sum_max_it_code_aux
concrete_definition sum_max_it_code for V uses sum_max_it_code_aux
theorem sum_max_it_code_correct:
assumes "ls.α V ≠ {}"
shows "sum_max_it_code V = (∑(ls.α V), Max (ls.α V))"
proof -
note sum_max_it_code.refine[of V]
also note sum_max_it_impl_refine[of V "ls.α V"]
also note sum_max_it_correct
finally show ?thesis using assms by (auto simp: refine_rel_defs)
qed
export_code sum_max_it_code checking SML
export_code sum_max_it_code checking OCaml?
export_code sum_max_it_code checking Haskell?
export_code sum_max_it_code checking Scala
definition "sum_max_it_list ≡ sum_max_it_code o ls.from_list"
ML_val ‹
@{code sum_max_it_list} (map @{code nat_of_integer} [1,2,3,4,5])
›
section ‹Pointwise Reasoning›
text ‹
In this section, we describe how to use pointwise reasoning to prove
refinement statements and other relations between element of the
nondeterminism monad.
Pointwise reasoning is often a powerful tool to show refinement between
structurally different program fragments.
›
text ‹
The refinement framework defines the predicates
@{const "nofail"} and @{const "inres"}.
@{term "nofail S"} states that ‹S› does not fail,
and @{term "inres S x"} states that one possible result of ‹S› is
‹x› (Note that this includes the case that ‹S› fails).
Equality and refinement can be stated using @{const "nofail"} and
@{const "inres"}:
@{thm [display] pw_eq_iff}
@{thm [display] pw_le_iff}
Useful corollaries of this lemma are
@{thm [source] pw_leI}, @{thm [source] pw_eqI}, and @{thm [source] pwD}.
Once a refinement has been expressed via nofail/inres, the simplifier can be
used to propagate the nofail and inres predicates inwards over the structure
of the program. The relevant lemmas are contained in the named theorem
collection ‹refine_pw_simps›.
As an example, we show refinement of two structurally different programs here,
both returning some value in a certain range:
›
lemma "do { ASSERT (fst p > 2); SPEC (λx. x≤(2::nat)*(fst p + snd p)) }
≤ do { let (x,y)=p; z←SPEC (λz. z≤x+y);
a←SPEC (λa. a≤x+y); ASSERT (x>2); RETURN (a+z)}"
apply (rule pw_leI)
apply (auto simp add: refine_pw_simps split: prod.split)
apply (rename_tac a b x)
apply (case_tac "x≤a+b")
apply (rule_tac x=0 in exI)
apply simp
apply (rule_tac x="a+b" in exI)
apply (simp)
apply (rule_tac x="x-(a+b)" in exI)
apply simp
done
section "Arbitrary Recursion (TBD)"
text ‹
While-loops are suited to express tail-recursion.
In order to express arbitrary recursion, the refinement framework provides
the nrec-mode for the ‹partial_function› command, as well as the fixed
point combinators @{const "REC"} (partial correctness) and
@{const "RECT"} (total correctness).
Examples for ‹partial_function› can be found in
‹ex/Refine_Fold›. Examples for the recursion combinators can be found
in ‹ex/Recursion› and ‹ex/Nested_DFS›.
›
section ‹Reference›
subsection ‹Statements› text_raw ‹\label{sec:stmt_ref}›
text ‹
\begin{description}
\item[@{const "SUCCEED"}] The empty set of results. Least element of
the refinement ordering.
\item[@{const "FAIL"}] Result that indicates a failing assertion.
Greatest element of the refinement ordering.
\item{@{term "RES X"}} All results from set ‹X›.
\item[@{term "RETURN x"}] Return single result ‹x›. Defined in
terms of ‹RES›: @{lemma "RETURN x = RES {x}" by simp}.
\item[@{term "EMBED r"}] Embed partial-correctness option type, i.e.,
succeed if ‹r=None›, otherwise return value of ‹r›.
\item[@{term "SPEC Φ"}] Specification.
All results that satisfy predicate ‹Φ›. Defined in terms of
@{term "RES"}: @{lemma "SPEC Φ = RES (Collect Φ)" by simp}
\item[@{term [source] "bind M f"}] Binding.
Nondeterministically choose a result from
‹M› and apply ‹f› to it. Note that usually the
‹do›-notation is used, i.e., ‹do {x←M; f x}› or
‹do {M;f}› if the result of ‹M› is not important.
If ‹M› fails, @{term [source] "bind M f"} also fails.
\item[@{term "ASSERT Φ"}] Assertion. Fails
if ‹Φ› does not hold, otherwise returns ‹()›.
Note that the default usage with the do-notation is:
@{term [source] "do {ASSERT Φ; f}"}.
\item[@{term "ASSUME Φ"}] Assumption. Succeeds
if ‹Φ› does not hold, otherwise returns ‹()›. Note that
the default usage with the do-notation is:
@{term [source] "do {ASSUME Φ; f}"}.
\item[@{term "REC body"}] Recursion for partial correctness.
May be used to express arbitrary recursion. Returns ‹SUCCEED› on
nontermination.
\item[@{term "RECT body"}] Recursion for total correctness.
Returns ‹FAIL› on nontermination.
\item[@{term "WHILE b f σ⇩0"}] Partial correct while-loop.
Start with state ‹σ⇩0›,
and repeatedly apply ‹f› as long as ‹b› holds for the
current state. Non-terminating paths are ignored, i.e., they do not
contribute a result.
\item[@{term "WHILE⇩T b f σ⇩0"}] Total correct while-loop. If there is a
non-terminating path, the result is @{term "FAIL"}.
\item[@{term "WHILE⇗I⇖ b f σ⇩0"}, @{term "WHILE⇩T⇗I⇖ b f σ⇩0"}] While-loop with
annotated invariant. It is asserted that the invariant holds.
\item[@{term "FOREACH S f σ⇩0"}] Foreach loop.
Start with state ‹σ⇩0›, and transform
the state with ‹f x› for each element ‹x∈S›. Asserts that
‹S› is finite.
\item[@{term "FOREACH⇗I⇖ S f σ⇩0"}] Foreach-loop with
annotated invariant.
Alternative syntax: @{term "FOREACHi I S f σ⇩0"}.
The invariant is a predicate of type
‹I::'a set ⇒ 'b ⇒ bool›, where ‹I it σ› means, that
the invariant holds for the remaining set of elements ‹it› and
current state ‹σ›.
\item[@{term "FOREACH⇩C S c f σ⇩0"}] Foreach-loop with explicit continuation
condition.
Alternative syntax: @{term "FOREACHc S c f σ⇩0"}.
If ‹c::'σ⇒bool› becomes false for the current state,
the iteration immediately terminates.
\item[@{term "FOREACH⇩C⇗I⇖ S c f σ⇩0"}] Foreach-loop with explicit continuation
condition and annotated invariant.
Alternative syntax: @{term "FOREACHci I S c f σ⇩0"}.
\item[‹partial_function (nrec)›] Mode of the partial function
package for the nondeterminism monad.
\end{description}
›
subsection ‹Refinement›
text ‹
\begin{description}
\item{@{term_type "(≤) :: 'a nres ⇒ 'a nres ⇒ bool"}}
Refinement ordering.
‹S ≤ S'› means, that every result in
‹S› is also a result in ‹S'›.
Moreover, ‹S› may only fail if ‹S'› fails.
‹≤› forms a complete lattice, with least element
‹SUCCEED› and greatest element ‹FAIL›.
\item{@{term "⇓R"}} Concretization. Takes a refinement relation
‹R::('c×'a) set› that relates concrete to abstract values,
and returns a concretization function
@{term "⇓R :: 'a nres ⇒ 'c nres"}.
\item{@{term "⇑R"}} Abstraction. Takes a refinement relation and
returns an abstraction function.
The functions ‹⇓R› and ‹⇑R› form a Galois-connection,
i.e., we have: ‹S ≤ ⇓R S' ⟷ ⇑R S ≤ S'›.
\item{@{term "build_rel α I"}} Builds a refinement relation from
an abstraction function and an invariant. Those refinement relations
are always single-valued.
\item{@{term "nofail S"}} Predicate that states that ‹S› does
not fail.
\item{@{term "inres S x"}} Predicate that states that ‹S›
includes result ‹x›. Note that a failing program includes all
results.
\end{description}
›
subsection‹Proof Tools›
text ‹
\begin{description}
\item{Verification Condition Generator:}
\begin{description}
\item[Method:] ‹intro refine_vcg›
\item[Attributes:] ‹refine_vcg›
\end{description}
Transforms a subgoal of the
form ‹S ≤ SPEC Φ› into verification conditions by
decomposing the structure of ‹S›. Invariants for loops
without annotation must be specified explicitely by instantiating
the respective proof-rule for the loop construct, e.g.,
‹intro WHILE_rule[where I=…] refine_vcg›.
‹refine_vcg› is a named theorems collection that contains
the rules that are used by default.
\item{Refinement Condition Generator:}
\begin{description}
\item[Method:] ‹refine_rcg› [thms].
\item[Attributes:] ‹refine0›, ‹refine›,
‹refine2›.
\item[Flags:] ‹refine_no_prod_split›.
\end{description}
Tries to prove a subgoal of the form ‹S ≤ ⇓R S'› by
decomposing the structure of ‹S› and ‹S'›.
The rules to be used are contained in the theorem collection
‹refine›. More rules may be passed as argument to the method.
Rules contained in ‹refine0› are always
tried first, and rules in ‹refine2› are tried last.
Usually, rules that decompose both programs equally
should be put into ‹refine›. Rules that may make big steps,
without decomposing the program further, should be put into
‹refine0› (e.g., @{thm [source] Id_refine}). Rules that
decompose the programs differently and shall be used as last resort
before giving up should be put into ‹refine2›, e.g.,
@{thm [source] remove_Let_refine}.
By default, this procedure will invoke the splitter to split
product types in the goals. This behaviour can be disabled by
setting the flag ‹refine_no_prod_split›.
\item{Refinement Relation Heuristics:}
\begin{description}
\item[Method:] ‹refine_dref_type› [(trace)].
\item[Attributes:] ‹refine_dref_RELATES›,
‹refine_dref_pattern›.
\item[Flags:] ‹refine_dref_tracing›.
\end{description}
Tries to instantiate schematic refinement relations based on their
type. By default, this rule is applied to all subgoals.
Internally, it uses the rules declared as
‹refine_dref_pattern› to introduce a goal of the form
‹RELATES ?R›, that is then solved by exhaustively
applying rules declared as ‹refine_dref_RELATES›.
The flag ‹refine_dref_tracing› controls tracing of
resolving ‹RELATES›-goals. Tracing may also be enabled by
passing (trace) as argument.
\item{Pointwise Reasoning Simplification Rules:}
\begin{description}
\item[Attributes:] ‹refine_pw_simps›
\end{description}
A theorem collection that contains
simplification lemmas to push inwards @{term "nofail"} and
@{term "inres"} predicates into program constructs.
\item{Refinement Simp Rules:}
\begin{description}
\item[Attributes:] ‹refine_hsimp›
\end{description}
A theorem collection that contains some
simplification lemmas that are useful to prove membership in
refinement relations.
\item{Transfer:}
\begin{description}
\item[Method:] ‹refine_transfer› [thms]
\item[Attribute:] ‹refine_transfer›
\end{description}
Tries to prove a subgoal of the form ‹α f ≤ S› by
decomposing the structure of ‹f› and ‹S›.
This is usually used in connection
with a schematic lemma, to generate ‹f› from the structure
of ‹S›.
The theorems declared as ‹refine_transfer› are used to do
the transfer. More theorems may be passed as arguments to the method.
Moreover, some simplification for nested abstraction
over product types (‹λ(a,b) (c,d). …›) is done, and the
monotonicity prover is used on monotonicity goals.
There is a standard setup for ‹α=RETURN›
(transfer to plain function for total correct code generation), and
‹α=nres_of› (transfer to deterministic result monad, for
partial correct code generation).
\item{Automatic Refinement:}
\begin{description}
\item[Method:] ‹refine_autoref›
\item[Attributes:] ...
\end{description}
See automatic refinement package for documentation (TBD)
\item{Concrete Definition:}
\begin{description}
\item[Command:]
‹concrete_definition name [attribs] for params uses thm›
where ‹attribs› and the ‹for›-part are optional.
Declares a new constant from the left-hand side of a refinement
lemma. Has special handling for left-hand sides of the forms
‹RETURN _› and ‹nres_of›, in which cases those
topmost functions are not included in the defined constant.
The refinement lemma is folded with the new constant and
registered as ‹name.refine›.
\item[Command:]
‹prepare_code_thms thms› takes a list of definitional
theorems and sets up lemmas for the code generator for those
definitions. This includes handling of recursion combinators.
\end{description}
\end{description}
›
subsection‹Packages›
text ‹
The following parts of the refinement framework are not included
by default, but can be imported if necessary:
\begin{description}
\item{Collection-Bindings:} Sets up refinement rules for the
Isabelle Collection Framework. With this theory loaded, the
refinement condition generator will discharge most data refinements
using the ICF automatically. Moreover, the transfer procedure
will replace ‹FOREACH›-statements by the corresponding
ICF-iterators.
\end{description}
›
end
Theory ICF_Userguide
theory ICF_Userguide
imports
"../ICF/Collections"
"../Lib/Code_Target_ICF"
begin
text_raw ‹\isasection{Isabelle Collections Framework Userguide}\label{thy:Userguide}›
section "Introduction"
text ‹
This is the Userguide for the (old) Isabelle Collection Framework.
It does not cover the Generic Collection Framework, nor the
Automatic Refinement Framework.
The Isabelle Collections Framework defines interfaces of various collection types and provides some standard implementations and generic algorithms.
The relation between the data structures of the collection framework and standard Isabelle types (e.g. for sets and maps) is established by abstraction functions.
Amongst others, the following interfaces and data-structures are provided by the Isabelle Collections Framework (For a complete list, see the overview section
in the implementations chapter of the proof document):
\begin{itemize}
\item Set and map implementations based on (associative) lists, red-black trees, hashing and tries.
\item An implementation of a FIFO-queue based on two stacks.
\item Annotated lists implemented by finger trees.
\item Priority queues implemented by binomial heaps, skew binomial heaps, and annotated lists (via finger trees).
\end{itemize}
The red-black trees are imported from the standard isabelle library. The binomial and skew binomial heaps are
imported from the {\em Binomial-Heaps} entry of the archive of formal proofs. The finger trees are imported from
the {\em Finger-Trees} entry of the archive of formal proofs.
›
subsection "Getting Started"
text ‹
To get started with the Isabelle Collections Framework (assuming that you are already familiar with Isabelle/HOL and Isar),
you should first read the introduction (this section), that provides many basic examples. More examples are in the examples/ subdirectory of the collection
framework.
Section~\ref{sec:userguide.structure} explains the concepts of the Isabelle Collections Framework in more detail.
Section~\ref{sec:userguide.ext} provides information on extending the framework along with detailed examples, and
Section~\ref{sec:userguide.design} contains a discussion on the design of this framework.
There is also a paper \cite{LammichLochbihler2010ITP} on the design of the Isabelle Collections Framework available.
›
subsection "Introductory Example"
text ‹
We introduce the Isabelle Collections Framework by a simple example.
Given a set of elements represented by a red-black tree, and a list,
we want to filter out all elements that are not contained in the set.
This can be done by Isabelle/HOL's @{const filter}-function\footnote{Note that Isabelle/HOL uses the list comprehension syntax @{term [source] "[x←l. P x]"}
as syntactic sugar for filtering a list.}:
›
definition rbt_restrict_list :: "'a::linorder rs ⇒ 'a list ⇒ 'a list"
where "rbt_restrict_list s l == [ x←l. rs.memb x s ]"
text ‹
The type @{typ "'a rs"} is the type of sets backed by red-black trees.
Note that the element type of sets backed by red-black trees must be
of sort ‹linorder›.
The function @{const rs.memb} tests membership on such sets.
›
text ‹Next, we show correctness of our function:›
lemma rbt_restrict_list_correct:
assumes [simp]: "rs.invar s"
shows "rbt_restrict_list s l = [x←l. x∈rs.α s]"
by (simp add: rbt_restrict_list_def rs.memb_correct)
text ‹
The lemma @{thm [source] rs.memb_correct}: @{thm [display] rs.memb_correct[no_vars]}
states correctness of the @{const rs.memb}-function.
The function @{const rs.α} maps a red-black-tree to the set that it represents.
Moreover, we have to explicitely keep track of the invariants of the used data structure,
in this case red-black trees.
The premise @{thm (prem 1) rs.memb_correct} represents the invariant assumption for the collection data structure.
Red-black-trees are invariant-free, so this defaults to @{term "True"}.
For uniformity reasons, these (unnecessary) invariant assumptions are present in all correctness lemmata.
Many of the correctness lemmas for standard RBT-set-operations are summarized by the lemma @{thm [source] rs.correct}:
@{thm [display] rs.correct[no_vars]}
›
text ‹
All implementations provided by this library are compatible with the Isabelle/HOL code-generator.
Now follow some examples of using the code-generator.
Note that the code generator can only generate code for plain constants
without arguments, while the operations like @{const rs.memb} have arguments,
that are only hidden by an abbreviation.
›
text ‹
There are conversion functions from lists to sets and, vice-versa, from sets to lists:
›
definition "conv_tests ≡ (
rs.from_list [1::int .. 10],
rs.to_list (rs.from_list [1::int .. 10]),
rs.to_sorted_list (rs.from_list [1::int,5,6,7,3,4,9,8,2,7,6]),
rs.to_rev_list (rs.from_list [1::int,5,6,7,3,4,9,8,2,7,6])
)"
ML_val ‹@{code conv_tests}›
text ‹
Note that sets make no guarantee about ordering, hence the only thing we can
prove about conversion from sets to lists is:
@{thm [source] rs.to_list_correct}: @{thm [display] rs.to_list_correct[no_vars]}
Some sets, like red-black-trees, also support conversion to sorted lists,
and we have:
@{thm [source] rs.to_sorted_list_correct}: @{thm [display] rs.to_sorted_list_correct[no_vars]} and
@{thm [source] rs.to_rev_list_correct}: @{thm [display] rs.to_rev_list_correct[no_vars]}
›
definition "restrict_list_test ≡ rbt_restrict_list (rs.from_list [1::nat,2,3,4,5]) [1::nat,9,2,3,4,5,6,5,4,3,6,7,8,9]"
ML_val ‹@{code restrict_list_test}›
definition "big_test n = (rs.from_list [(1::int)..n])"
ML_val ‹@{code big_test} (@{code int_of_integer} 9000)›
subsection "Theories"
text ‹
To make available the whole collections framework to your formalization,
import the theory @{theory Collections.Collections} which includes everything. Here is a
small selection:
\begin{description}
\item[@{theory Collections.SetSpec}] Specification of sets and set functions
\item[@{theory Collections.SetGA}] Generic algorithms for sets
\item[@{theory Collections.SetStdImpl}] Standard set implementations (list, rb-tree, hashing, tries)
\item[@{theory Collections.MapSpec}] Specification of maps
\item[@{theory Collections.MapGA}] Generic algorithms for maps
\item[@{theory Collections.MapStdImpl}] Standard map implementations (list,rb-tree, hashing, tries)
\item[@{theory Collections.ListSpec}] Specification of lists
\item[@{theory Collections.Fifo}] Amortized fifo queue
\item[@{theory Collections.DatRef}] Data refinement for the while combinator
\end{description}
›
subsection "Iterators"
text ‹An important concept when using collections are iterators. An iterator is a kind of generalized fold-functional.
Like the fold-functional, it applies a function to all elements of a set and modifies a state. There are
no guarantees about the iteration order. But, unlike the fold functional, you can prove useful properties of iterations
even if the function is not left-commutative. Proofs about iterations are done in invariant style, establishing an
invariant over the iteration.
The iterator combinator for red-black tree sets is @{const rs.iterate}, and the proof-rule that is usually used is:
@{thm [source] rs.iteratei_rule_P}: @{thm [display] rs.iteratei_rule_P[no_vars]}
The invariant @{term I} is parameterized with the set of remaining elements that have not yet been iterated over and the
current state. The invariant has to hold for all elements remaining and the initial state: @{term "I (rs.α S) σ0"}.
Moreover, the invariant has to be preserved by an iteration step:
@{term [display] "⋀x it σ. ⟦x ∈ it; it ⊆ rs.α S; I it σ⟧ ⟹ I (it - {x}) (f x σ)"}
And the proposition to be shown for the final state must be a consequence of the invarant for no
elements remaining: @{term "⋀σ. I {} σ ⟹ P σ"}.
A generalization of iterators are {\em interruptible iterators} where iteration is only continues while some condition on the state holds.
Reasoning over interruptible iterators is also done by invariants:
@{thm [source] rs.iteratei_rule_P}: @{thm [display] rs.iteratei_rule_P[no_vars]}
Here, interruption of the iteration is handled by the premise
@{term [display] "⋀σ it. ⟦it ⊆ rs.α S; it ≠ {}; ¬ c σ; I it σ⟧ ⟹ P σ"}
that shows the proposition from the invariant for any intermediate state of the
iteration where the continuation condition
does not hold (and thus the iteration is interrupted).
›
text ‹
As an example of reasoning about results of iterators, we implement a function
that converts a hashset to a list that contains precisely the elements of the set.
›
definition "hs_to_list' s == hs.iteratei s (λ_. True) (#) []"
text ‹
The correctness proof works by establishing the invariant that the list contains
all elements that have already been iterated over.
Again @{term "hs.invar s"} denotes the invariant for hashsets which defaults to @{term "True"}.
›
lemma hs_to_list'_correct:
assumes INV: "hs.invar s"
shows "set (hs_to_list' s) = hs.α s"
apply (unfold hs_to_list'_def)
apply (rule_tac
I="λit σ. set σ = hs.α s - it"
in hs.iterate_rule_P[OF INV])
txt ‹The resulting proof obligations are easily discharged using auto:›
apply auto
done
text ‹
As an example for an interruptible iterator,
we define a bounded existential-quantification over the list elements.
As soon as the first element is found that fulfills the predicate,
the iteration is interrupted.
The state of the iteration is simply a boolean, indicating the (current) result of the quantification:
›
definition "hs_bex s P == hs.iteratei s (λσ. ¬ σ) (λx σ. P x) False"
lemma hs_bex_correct:
"hs.invar s ⟹ hs_bex s P ⟷ (∃x∈hs.α s. P x)"
apply (unfold hs_bex_def)
txt ‹The invariant states that the current result matches the result of the quantification
over the elements already iterated over:›
apply (rule_tac
I="λit σ. σ ⟷ (∃x∈hs.α s - it. P x)"
in hs.iteratei_rule_P)
txt ‹The resulting proof obligations are easily discharged by auto:›
apply auto
done
section "Structure of the Framework"
text_raw ‹\label{sec:userguide.structure}›
text ‹
The concepts of the framework are roughly based on the object-oriented concepts of interfaces, implementations and generic algorithms.
The concepts used in the framework are the following:
\begin{description}
\item[Interfaces] An interface describes some concept by providing an abstraction mapping $\alpha$ to a related Isabelle/HOL-concept.
The definition is generic in the datatype used to implement the concept (i.e. the concrete data structure). An interface is specified by means
of a locale that fixes the abstraction mapping and an invariant.
For example, the set-interface contains an abstraction mapping to sets, and is specified by the locale ‹SetSpec.set›.
An interface roughly matches the concept of a (collection) interface in Java, e.g. {\em java.util.Set}.
\item[Functions] A function specifies some functionality involving interfaces. A function is specified by means of a locale.
For example, membership query for a set is specified by the locale @{const [source] SetSpec.set_memb} and
equality test between two sets is a function specified by @{const [source] SetSpec.set_equal}.
A function roughly matches a method declared in an interface, e.g. {\em java.util.Set\#contains, java.util.Set\#equals}.
\item[Operation Records] In order to reference an interface with a standard
set of operations, those operations are summarized in a record, and there
is a locale that fixes this record, and makes available all operations.
For example, the locale @{const [source] SetSpec.StdSet} fixes a record
of standard set operations and assumes their correctness. It also defines
abbreviations to easily access the members of the record. Internally,
all the standard operations, like @{const hs.memb}, are introduced by
interpretation of such an operation locale.
\item[Generic Algorithms] A generic algorithm specifies, in a generic way,
how to implement a function using other functions. Usually, a generic
algorithm lives in a locale that imports the necessary operation locales.
For example, the locale @{const SetGA.cart_loc} defines a generic
algorithm for the cartesian product between two sets.
There is no direct match of generic algorithms in the Java
Collections Framework. The most related concept are abstract
collection interfaces, that provide some default algorithms,
e.g. {\em java.util.AbstractSet}. The concept of {\em Algorithm} in
the C++ Standard Template Library \cite{C++STL} matches the concept
of Generic Algorithm quite well.
\item[Implementation] An implementation of an interface provides a
data structure for that interface together with an abstraction
mapping and an invariant. Moreover, it provides implementations
for some (or all) functions of that interface. For example,
red-black trees are an implementation of the set-interface,
with the abstraction mapping @{const rs.α} and invariant
@{const rs.invar}; and the constant @{const rs.ins} implements
the insert-function, as can be verified by
@{lemma "set_ins rs.α rs.invar rs.ins" by unfold_locales}.
An implementation matches a concrete collection
interface in Java, e.g. {\em java.util.TreeSet}, and the
methods implemented by such an interface, e.g. {\em
java.util.TreeSet\#add}.
\item[Instantiation] An instantiation of a generic algorithm
provides actual implementations for the used functions. For
example, the generic cartesian-product algorithm can be
instantiated to use red-black-trees for both arguments, and output
a list, as will be illustrated below in Section~\ref{sec:inst_gen_algo}.
While some of the functions
of an implementation need to be implemented specifically, many
functions may be obtained by instantiating generic algorithms.
In Java, instantiation of a generic algorithm is matched most
closely by inheriting from an abstract collection
interface. In the C++ Standard Template Library instantiation
of generic algorithms is done implicitely by the compiler.
\end{description}
›
subsection "Instantiation of Generic Algorithms" text_raw ‹\label{sec:inst_gen_algo}›
text ‹A generic algorithm is instantiated by interpreting its locale with
the wanted implementations. For example, to obtain a cartesian product
between two red-black trees, yielding a list, we can do the following:›
setup Locale_Code.open_block
interpretation rrl: cart_loc rs_ops rs_ops ls_ops by unfold_locales
setup Locale_Code.close_block
setup ‹ICF_Tools.revert_abbrevs "rrl"›
text ‹It is then available under the expected name:›
term "rrl.cart"
text ‹Note the three lines of boilerplate code, that work around some
technical problems of Isabelle/HOL: The ‹Locale_Code.open_block› and
‹Locale_Code.close_block› commands set up code generation for any
locale that is interpreted in between them. They also have to be specified
if an existing locale that already has interpretations is extended by
new definitions.
The ‹ICF_Tools.revert_abbrevs "rrl"› reverts all
abbreviations introduced by the locale, such that the displayed
information becomes nicer.
›
subsection "Naming Conventions"
text ‹
The Isabelle Collections Framework follows these general naming conventions.
Each implementation has a two-letter (or three-letter) and a one-letter (or two-letter) abbreviation, that are used as prefixes for the related constants, lemmas and instantiations.
The two-letter and three-letter abbreviations should be unique over all interfaces and instantiations, the one-letter abbreviations should be unique
over all implementations of the same interface.
Names that reference the implementation of only one interface are prefixed with that implementation's two-letter abbreviation (e.g. @{const hs.ins} for insertion into a HashSet (hs,h)),
names that reference more than one implementation are prefixed with the one-letter (or two-letter) abbreviations (e.g. @{const rrl.cart} for the cartesian
product between two RBT-Sets, yielding a list-set)
The most important abbreviations are:
\begin{description}
\item[lm,l] List Map
\item[lmi,li] List Map with explicit invariant
\item[rm,r] RB-Tree Map
\item[hm,h] Hash Map
\item[ahm,a] Array-based hash map
\item[tm,t] Trie Map
\item[ls,l] List Set
\item[lsi,li] List Set with explicit invariant
\item[rs,r] RB-Tree Set
\item[hs,h] Hash Set
\item[ahs,a] Array-based hash map
\item[ts,t] Trie Set
\end{description}
Each function ‹name› of an interface ‹interface› is declared in a locale ‹interface_name›. This locale provides a fact ‹name_correct›. For example, there is the locale @{const set_ins} providing
the fact @{thm [source] set_ins.ins_correct}.
An implementation instantiates the locales of all implemented functions, using its two-letter abbreviation as instantiation prefix. For example, the HashSet-implementation instantiates the locale @{const set_ins}
with the prefix {\em hs}, yielding the lemma @{thm [source] hs.ins_correct}. Moreover, an implementation with two-letter abbreviation {\em aa} provides a lemma ‹aa.correct›
that summarizes the correctness facts for the basic
operations. It should only contain those facts that are safe to be used with the simplifier. E.g., the correctness facts for basic operations on hash sets are available via the lemma @{thm [source] hs.correct}.
›
section "Extending the Framework"
text_raw ‹\label{sec:userguide.ext}›
text ‹
The best way to add new features, i.e., interfaces, functions,
generic algorithms, or implementations to the collection framework is to use
one of the existing items as example.
›
section "Design Issues"
text_raw ‹\label{sec:userguide.design}›
text ‹
In this section, we motivate some of the design decisions of the Isabelle Collections Framework and report our experience with alternatives.
Many of the design decisions are justified by restrictions of Isabelle/HOL and the code generator, so that there may be better
options if those restrictions should vanish from future releases of Isabelle/HOL.
›
text ‹
The main design goals of this development are:
\begin{enumerate}
\item\label{dg_unified} Make available various implementations of collections under a unified interface.
\item\label{dg_extensible} It should be easy to extend the framework by new interfaces, functions, algorithms, and implementations.
\item\label{dg_concise} Allow simple and concise reasoning over functions using collections.
\item\label{dg_genalgo} Allow generic algorithms, that are independent of the actual data structure that is used.
\item\label{dg_exec} Support generation of executable code.
\item\label{dg_control} Let the user precisely control what data structures are used in the implementation.
\end{enumerate}
›
subsection ‹Data Refinement›
text ‹
In order to allow simple reasoning over collections, we use a data refinement approach. Each collection
interface has an abstraction function that maps it on a related Isabelle/HOL concept (abstract level).
The specification of functions are also relative to the abstraction.
This allows most of the correctness reasoning to be done on the abstract level. On this level,
the tool support is more elaborated and one is not yet fixed to a concrete implementation.
In a next step, the abstract specification is refined to use an actual implementation (concrete level). The correctness properties
proven on the abstract level usually transfer easily to the concrete level.
Moreover, the user has precise control how the refinement is done, i.e. what data structures are used. An alternative would be to do refinement
completely automatic, as e.g. done in the code generator setup of the Theory~{\em Executable-Set}. This has the advantage that it induces less writing overhead.
The disadvantage is that the user looses a great amount of control over the refinement. For example, in {\em Executable-Set}, all sets have to be represented by lists,
and there is no possibility to represent one set differently from another.
For a more detailed discussion of the data refinement issue, we refer to
the monadic refinement framework, that is available in the AFP
(@{url "http://isa-afp.org/entries/Refine_Monadic.shtml"})
›
subsection ‹Operation Records›
text ‹
In order to allow convenient access to the most frequently used functions
of an interface,
we have grouped them together in a record, and defined a locale that only
fixes this record. This greatly reduces the boilerplate required to define
a new (generic) algorithm, as only the operation locale (instead of every
single function) has to be included in the locale for the generic algorithm.
Note however, that parameters of locales are monomorphic inside the locale.
Thus, we have to import an own instance for the locale for every element
type of a set, or key/value type of a map.
For iterators, where this problem was most annoying, we have installed a
workaround that allows polymorphic iterators even inside locales.
›
subsection ‹Locales for Generic Algorithms›
text ‹
A generic algorithm is defined within a locale, that includes the required
functions (or operation locales). If many instances of the same interface
are required, prefixes are used to distinguish between them. This makes
the code for a generic algorithm quite consise and readable.
However, there are some technical issues that one has to consider:
\begin{itemize}
\item When fixing parameters in the declaration of the locale, their
types will be inferred independently of the definitions later done in
the locale context. In order to get the correct types, one has to add
explicit type constraints.
\item The code generator has problems with generating code from
definitions inside a locale. Currently, the ‹Locale_Code›-package
provides a rather convenient workaround for that issue: It requires the
user to enclose interpretations and definitions of new constants inside
already interpreted locales within two special commands, that set up
the code generator appropriately.
\end{itemize}
›
subsection ‹Explicit Invariants vs Typedef›
text ‹
The interfaces of this framework use explicit invariants.
This provides a more general specification which allows some operations to
be implemented more efficiently, cf. @{const "lsi.ins_dj"}
in @{theory Collections.ListSetImpl_Invar}.
Most implementations, however, hide the invariant in a typedef and setup
the code generator appropriately.
In that case, the invariant is just @{term "λ_. True"}, and removed
automatically by the simplifier and classical reasoner.
However, it still shows up in some premises and conclusions due to
uniformity reasons.
›
end